From: Stephane Glondu Date: Thu, 17 Oct 2013 09:40:02 +0000 (+0200) Subject: Imported Upstream version 4.01.0 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~9 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=df912e4b5d45ea9f8b9b54909bfdfb80fc9a0824;p=ocaml.git Imported Upstream version 4.01.0 --- diff --git a/.depend b/.depend index e61be554..50b63374 100644 --- a/.depend +++ b/.depend @@ -24,6 +24,8 @@ utils/terminfo.cmo : utils/terminfo.cmi utils/terminfo.cmx : utils/terminfo.cmi utils/warnings.cmo : utils/warnings.cmi utils/warnings.cmx : utils/warnings.cmi +parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/asttypes.cmi : parsing/location.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi @@ -33,8 +35,16 @@ parsing/parser.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi +parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/asttypes.cmi parsing/printast.cmi : parsing/parsetree.cmi parsing/syntaxerr.cmi : parsing/location.cmi +parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi utils/config.cmi parsing/asttypes.cmi \ + parsing/ast_mapper.cmi +parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + parsing/location.cmx utils/config.cmx parsing/asttypes.cmi \ + parsing/ast_mapper.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ @@ -55,6 +65,10 @@ parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ parsing/asttypes.cmi parsing/parser.cmi +parsing/pprintast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/pprintast.cmi +parsing/pprintast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + parsing/location.cmx parsing/asttypes.cmi parsing/pprintast.cmi parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ @@ -72,7 +86,8 @@ typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ parsing/asttypes.cmi typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \ typing/path.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi utils/consistbl.cmi typing/annot.cmi + typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi +typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi typing/ident.cmi : typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ @@ -84,14 +99,15 @@ typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi typing/oprint.cmi : typing/outcometree.cmi typing/outcometree.cmi : parsing/asttypes.cmi -typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi typing/path.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 typing/path.cmi : typing/ident.cmi typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/primitive.cmi : typing/printtyp.cmi : typing/types.cmi typing/path.cmi \ - typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi + typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi typing/printtyped.cmi : typing/typedtree.cmi typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ typing/annot.cmi @@ -109,6 +125,8 @@ typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi parsing/asttypes.cmi +typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi +typing/typedtreeMap.cmi : typing/typedtree.cmi typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includemod.cmi typing/ident.cmi typing/env.cmi @@ -119,21 +137,21 @@ 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 typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ - typing/btype.cmi + typing/ident.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ - typing/btype.cmi + typing/ident.cmx typing/btype.cmi typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ utils/config.cmi typing/cmi_format.cmi typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ utils/config.cmx typing/cmi_format.cmi -typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi utils/misc.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/env.cmi utils/config.cmi \ - typing/cmi_format.cmi utils/clflags.cmi parsing/asttypes.cmi \ - typing/cmt_format.cmi -typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx utils/misc.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/env.cmx utils/config.cmx \ - typing/cmi_format.cmx utils/clflags.cmx parsing/asttypes.cmi \ - typing/cmt_format.cmi +typing/cmt_format.cmo : typing/types.cmi typing/typedtreeMap.cmi \ + typing/typedtree.cmi utils/misc.cmi parsing/location.cmi \ + parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \ + utils/clflags.cmi typing/cmt_format.cmi +typing/cmt_format.cmx : typing/types.cmx typing/typedtreeMap.cmx \ + typing/typedtree.cmx utils/misc.cmx parsing/location.cmx \ + parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \ + utils/clflags.cmx typing/cmt_format.cmi typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \ @@ -142,10 +160,10 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi -typing/datarepr.cmo : typing/types.cmi typing/predef.cmi utils/misc.cmi \ +typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \ typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/datarepr.cmi -typing/datarepr.cmx : typing/types.cmx typing/predef.cmx utils/misc.cmx \ +typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \ typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/datarepr.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ @@ -153,13 +171,19 @@ typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \ typing/cmi_format.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/annot.cmi typing/env.cmi + parsing/asttypes.cmi typing/env.cmi typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/annot.cmi typing/env.cmi + parsing/asttypes.cmi typing/env.cmi +typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ + typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi +typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ + typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : typing/ident.cmi typing/ident.cmx : typing/ident.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ @@ -216,14 +240,16 @@ typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/printtyp.cmi + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/printtyp.cmi typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ - typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/printtyp.cmi + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/printtyp.cmi typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ parsing/asttypes.cmi typing/printtyped.cmi @@ -296,6 +322,14 @@ typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi +typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \ + typing/typedtreeIter.cmi +typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \ + typing/typedtreeIter.cmi +typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ + parsing/asttypes.cmi typing/typedtreeMap.cmi +typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ + parsing/asttypes.cmi typing/typedtreeMap.cmi typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ @@ -314,10 +348,10 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/typemod.cmi -typing/types.cmo : typing/primitive.cmi typing/path.cmi utils/misc.cmi \ +typing/types.cmo : typing/primitive.cmi typing/path.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ parsing/asttypes.cmi typing/types.cmi -typing/types.cmx : typing/primitive.cmx typing/path.cmx utils/misc.cmx \ +typing/types.cmx : typing/primitive.cmx typing/path.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ parsing/asttypes.cmi typing/types.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ @@ -350,12 +384,13 @@ bytecomp/printlambda.cmi : bytecomp/lambda.cmi bytecomp/runtimedef.cmi : bytecomp/simplif.cmi : bytecomp/lambda.cmi bytecomp/switch.cmi : -bytecomp/symtable.cmi : typing/ident.cmi bytecomp/cmo_format.cmi +bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ - typing/primitive.cmi typing/path.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/translcore.cmi : typing/typedtree.cmi typing/primitive.cmi \ + typing/path.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + parsing/asttypes.cmi bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi @@ -376,17 +411,15 @@ bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \ utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \ - bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ - 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/opcodes.cmo utils/misc.cmi parsing/location.cmi typing/ident.cmi \ + bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \ + bytecomp/bytesections.cmi bytecomp/bytelink.cmi bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ - bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ - bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \ - utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ - bytecomp/bytelink.cmi + bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ + bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ + bytecomp/bytesections.cmx bytecomp/bytelink.cmi bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \ bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ @@ -479,28 +512,28 @@ bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ bytecomp/symtable.cmi bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ - typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.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 \ typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ - typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.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/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ - typing/typedtree.cmi bytecomp/translobj.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 \ - typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \ - typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \ - bytecomp/matching.cmx parsing/longident.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/translcore.cmi +bytecomp/translcore.cmo : utils/warnings.cmi typing/types.cmi \ + bytecomp/typeopt.cmi typing/typedtree.cmi bytecomp/translobj.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 : utils/warnings.cmx typing/types.cmx \ + bytecomp/typeopt.cmx typing/typedtree.cmx bytecomp/translobj.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ @@ -522,13 +555,11 @@ bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/translobj.cmi bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - parsing/asttypes.cmi bytecomp/typeopt.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/primitive.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - parsing/asttypes.cmi bytecomp/typeopt.cmi + typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi @@ -574,21 +605,23 @@ asmcomp/arch.cmx : asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ - asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ - utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \ - asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ - asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ - asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi + asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ + typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ + asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \ + asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ + asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ + asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ + asmcomp/asmgen.cmi asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ - asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ - utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \ - asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ - asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ - asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi + asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ + typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ + asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \ + asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ + asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ + asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ @@ -608,16 +641,14 @@ asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx asmcomp/proc.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ - utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.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/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \ - utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ + utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ asmcomp/asmpackager.cmi asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi @@ -626,11 +657,11 @@ asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/closure.cmi + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/closure.cmi + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ asmcomp/cmm.cmi asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ @@ -681,16 +712,14 @@ asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi -asmcomp/emitaux.cmo : asmcomp/reg.cmi asmcomp/linearize.cmi \ - asmcomp/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \ - asmcomp/arch.cmo asmcomp/emitaux.cmi -asmcomp/emitaux.cmx : asmcomp/reg.cmx asmcomp/linearize.cmx \ - asmcomp/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \ - asmcomp/arch.cmx asmcomp/emitaux.cmi -asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/interf.cmi -asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/interf.cmi +asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \ + utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \ + utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi +asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/interf.cmi +asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/interf.cmi asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/linearize.cmi @@ -708,11 +737,11 @@ asmcomp/mach.cmo : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/mach.cmi asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ - typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/printclambda.cmi + typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/printclambda.cmi asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ - typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/printclambda.cmi + typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/printclambda.cmi asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/printcmm.cmi asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \ @@ -743,10 +772,10 @@ asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/reloadgen.cmi -asmcomp/schedgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi -asmcomp/schedgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi @@ -759,12 +788,12 @@ asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/selectgen.cmi -asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/reg.cmi \ - asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi \ - utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/reg.cmx \ - asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx \ - utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/selection.cmi asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -773,28 +802,42 @@ 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 -driver/compile.cmi : typing/env.cmi +driver/compenv.cmi : +driver/compile.cmi : +driver/compmisc.cmi : typing/env.cmi driver/errors.cmi : driver/main.cmi : driver/main_args.cmi : -driver/optcompile.cmi : typing/env.cmi +driver/optcompile.cmi : driver/opterrors.cmi : driver/optmain.cmi : driver/pparse.cmi : +driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi utils/clflags.cmi driver/compenv.cmi +driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx utils/clflags.cmx driver/compenv.cmi driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ - typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \ - bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ - bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \ - parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \ - typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ + parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ + parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ + typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \ + utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ - typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \ - bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ - bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \ - parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ - typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \ + parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ + parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ + typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \ + utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi +driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \ + utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi +driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \ + utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ @@ -813,28 +856,34 @@ driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \ bytecomp/bytelibrarian.cmx driver/errors.cmi driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ parsing/location.cmi driver/errors.cmi utils/config.cmi \ - driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \ - bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.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/misc.cmx driver/main_args.cmx \ parsing/location.cmx driver/errors.cmx utils/config.cmx \ - driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \ - bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi + 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_args.cmo : utils/warnings.cmi driver/main_args.cmi driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ - typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \ - bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ - parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ - asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \ - asmcomp/asmgen.cmi driver/optcompile.cmi + typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + parsing/pprintast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \ + parsing/location.cmi typing/includemod.cmi typing/env.cmi \ + utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \ + driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi \ + driver/optcompile.cmi driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ - typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \ - bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ - parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ - asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \ - asmcomp/asmgen.cmx driver/optcompile.cmi + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + parsing/pprintast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \ + parsing/location.cmx typing/includemod.cmx typing/env.cmx \ + utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \ + driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx \ + driver/optcompile.cmi driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ @@ -854,13 +903,15 @@ driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \ driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - utils/clflags.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ - asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi + driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ + asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ + asmcomp/arch.cmo driver/optmain.cmi driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \ driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - utils/clflags.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ - asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi + driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ + asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ + asmcomp/arch.cmx driver/optmain.cmi driver/pparse.cmo : utils/misc.cmi parsing/location.cmi utils/clflags.cmi \ utils/ccomp.cmi driver/pparse.cmi driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ @@ -892,45 +943,47 @@ toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \ - typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \ - utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ - typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ + typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \ + parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ toplevel/opttopdirs.cmi toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \ - typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \ - utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ - typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ + typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \ + parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ toplevel/opttopdirs.cmi toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ - bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ - bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ - typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \ + bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + driver/opterrors.cmi typing/oprint.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ - asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \ - asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi + driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ + typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ + toplevel/opttoploop.cmi toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ - bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ - bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ - typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \ + bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + driver/opterrors.cmx typing/oprint.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ - asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \ - asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi + driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ + typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ + toplevel/opttoploop.cmi toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - utils/clflags.cmi toplevel/opttopmain.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 driver/opterrors.cmx \ utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - utils/clflags.cmx toplevel/opttopmain.cmi + driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ @@ -948,35 +1001,37 @@ toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ - typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ - parsing/printast.cmi typing/predef.cmi typing/path.cmi \ + typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ + bytecomp/printinstr.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 bytecomp/meta.cmi parsing/longident.cmi \ parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ - utils/config.cmi driver/compile.cmi utils/clflags.cmi \ + utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \ bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \ - typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \ - parsing/printast.cmx typing/predef.cmx typing/path.cmx \ + typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ + bytecomp/printinstr.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 bytecomp/meta.cmx parsing/longident.cmx \ parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ - utils/config.cmx driver/compile.cmx utils/clflags.cmx \ + utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \ bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi driver/errors.cmi utils/config.cmi utils/clflags.cmi \ - toplevel/topmain.cmi + parsing/location.cmi driver/errors.cmi utils/config.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 driver/errors.cmx utils/config.cmx utils/clflags.cmx \ - toplevel/topmain.cmi + parsing/location.cmx driver/errors.cmx utils/config.cmx \ + driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi toplevel/topstart.cmo : toplevel/topmain.cmi toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ diff --git a/.ignore b/.ignore index c801c474..7e8d3f05 100644 --- a/.ignore +++ b/.ignore @@ -11,6 +11,8 @@ package-macosx _boot_log1 _boot_log2 _build +_start +_buildtest _log myocamlbuild_config.ml ocamlbuild-mixed-boot diff --git a/Changes b/Changes index 0b06ed94..1056294a 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,432 @@ +OCaml 4.01.0: +------------- + +(Changes that can break existing programs are marked with a "*") + +Other libraries: +- Labltk: updated to Tcl/Tk 8.6. + +Type system: +- PR#5759: use well-disciplined type information propagation to + disambiguate label and constructor names + (Jacques Garrigue, Alain Frisch and Leo P. White) +* Propagate type information towards pattern-matching, even in the presence of + polymorphic variants (discarding only information about possibly-present + constructors). As a result, matching against absent constructors is no longer + allowed for exact and fixed polymorphic variant types. + (Jacques Garrigue) +* PR#6035: Reject multiple declarations of the same method or instance variable + in an object + (Alain Frisch) + +Compilers: +- PR#5861: raise an error when multiple private keywords are used in type + declarations + (Hongbo Zhang) +- PR#5634: parsetree rewriter (-ppx flag) + (Alain Frisch) +- ocamldep now supports -absname + (Alain Frisch) +- PR#5768: On "unbound identifier" errors, use spell-checking to suggest names + present in the environment + (Gabriel Scherer) +- ocamlc has a new option -dsource to visualize the parsetree + (Alain Frisch, Hongbo Zhang) +- tools/eqparsetree compares two parsetree ignoring location + (Hongbo Zhang) +- ocamlopt now uses clang as assembler on OS X if available, which enables + CFI support for OS X. + (Benedikt Meurer) +- Added a new -short-paths option, which attempts to use the shortest + representation for type constructors inside types, taking open modules + into account. This can make types much more readable if your code + uses lots of functors. + (Jacques Garrigue) +- PR#5986: added flag -compat-32 to ocamlc, ensuring that the generated + bytecode executable can be loaded on 32-bit hosts. + (Xavier Leroy) +- PR#5980: warning on open statements which shadow an existing + identifier (if it is actually used in the scope of the open); new + open! syntax to silence it locally + (Alain Frisch, thanks to a report of Daniel Bünzli) +* warning 3 is extended to warn about other deprecated features: + - ISO-latin1 characters in identifiers + - uses of the (&) and (or) operators instead of (&&) and (||) + (Damien Doligez) +- Experimental OCAMLPARAM for ocamlc and ocamlopt + (Fabrice Le Fessant) +- PR#5571: incorrect ordinal number in error message + (Alain Frisch, report by John Carr) +- PR#6073: add signature to Tstr_include + (patch by Leo P. White) + +Standard library: +- PR#5899: expose a way to inspect the current call stack, + Printexc.get_callstack + (Gabriel Scherer, Jacques-Henri Jourdan, Alain Frisch) +- PR#5986: new flag Marshal.Compat_32 for the serialization functions + (Marshal.to_*), forcing the output to be readable on 32-bit hosts. + (Xavier Leroy) +- infix application operators |> and @@ in Pervasives + (Fabrice Le Fessant) + +Other libraries: +- PR#5568: add O_CLOEXEC flag to Unix.openfile, so that the returned + file descriptor is created in close-on-exec mode + (Xavier Leroy) + +Runtime system: +* PR#6019: more efficient implementation of caml_modify() and caml_initialize(). + The new implementations are less lenient than the old ones: now, + the destination pointer of caml_modify() must point within the minor or + major heaps, and the destination pointer of caml_initialize() must + point within the major heap. + (Xavier Leroy, from an experiment by Brian Nigito, with feedback + from Yaron Minsky and Gerd Stolpmann) + +Internals: +- Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary + as part of compilerlibs, to be used on bin-annot files. + (Fabrice Le Fessant) +- The test suite can now be run without installing OCaml first. + (Damien Doligez) + +Bug fixes: +- PR#3236: Document the fact that queues are not thread-safe + (Damien Doligez) +- PR#3468: (part 1) Sys_error documentation + (Damien Doligez) +- PR#3679: Warning display problems + (Fabrice Le Fessant) +- PR#3963: Graphics.wait_next_event in Win32 hangs if window closed + (Damien Doligez) +- PR#4079: Queue.copy is now tail-recursive + (patch by Christophe Papazian) +- PR#4138: Documentation for Unix.mkdir + (Damien Doligez) +- PR#4469: emacs mode: caml-set-compile-command is annoying with ocamlbuild + (Daniel Bünzli) +- PR#4485: Graphics: Keyboard events incorrectly delivered in native code + (Damien Doligez, report by Sharvil Nanavati) +- PR#4502: ocamlbuild now reliably excludes the build-dir from hygiene check + (Gabriel Scherer, report by Romain Bardou) +- PR#4762: ?? is not used at all, but registered as a lexer token + (Alain Frisch) +- PR#4788: wrong error message when executable file is not found for backtrace + (Damien Doligez, report by Claudio Sacerdoti Coen) +- PR#4812: otherlibs/unix: add extern int code_of_unix_error (value error); + (Goswin von Berdelow) +- PR#4887: input_char after close_in crashes ocaml (msvc runtime) + (Alain Frisch and Christoph Bauer, report by ygrek) +- PR#4994: ocaml-mode doesn't work with xemacs21 + (Damien Doligez, report by Stéphane Glondu) +- PR#5098: creating module values may lead to memory leaks + (Alain Frisch, report by Milan Stanojević) +- PR#5102: ocamlbuild fails when using an unbound variable in rule dependency + (Xavier Clerc, report by Daniel Bünzli) +* PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails, + rather than raising 'Not_found' + (ygrek) +- PR#5121: %( %) in Format module seems to be broken + (Pierre Weis, first patch by Valentin Gatien-Baron, report by Khoo Yit Phang) +- PR#5178: document in INSTALL how to build a 32-bit version under Linux x86-64 + (Benjamin Monate) +- PR#5212: Improve ocamlbuild error messages of _tags parser + (ygrek) +- PR#5240: register exception printers for Unix.Unix_error and Dynlink.Error + (Jérémie Dimino) +- PR#5300: ocamlbuild: verbose parameter should implicitly set classic display + (Xavier Clerc, report by Robert Jakob) +- PR#5327: (Windows) Unix.select blocks if same socket listed in first and + third arguments + (David Allsopp, displaying impressive MSDN skills) +- PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound) + (Jacques Garrigue) +- PR#5350: missing return code checks in the runtime system + (Xavier Leroy) +- PR#5468: ocamlbuild should preserve order of parametric tags + (Wojciech Meyer, report by Dario Texeira) +- PR#5551: Avoid repeated lookups for missing cmi files + (Alain Frisch) +- PR#5552: unrecognized gcc option -no-cpp-precomp + (Damien Doligez, report by Markus Mottl) +- PR#5580: missed opportunities for constant propagation + (Xavier Leroy and John Carr) +- PR#5611: avoid clashes betwen .cmo files and output files during linking + (Wojciech Meyer) +- PR#5662: typo in md5.c + (Olivier Andrieu) +- PR#5673: type equality in a polymorphic field + (Jacques Garrigue, report by Jean-Louis Giavitto) +- PR#5674: Methods call are 2 times slower with 4.00 than with 3.12 + (Jacques Garrigue, Gabriel Scherer, report by Jean-Louis Giavitto) +- PR#5694: Exception raised by type checker + (Jacques Garrigue, report by Markus Mottl) +- PR#5695: remove warnings on sparc code emitter + (Fabrice Le Fessant) +- PR#5697: better location for warnings on statement expressions + (Dan Bensen) +- PR#5698: remove harcoded limit of 200000 labels in emitaux.ml + (Fabrice Le Fessant, report by Marcin Sawicki) +- PR#5702: bytecomp/bytelibrarian lib_sharedobjs was defined but never used + (Hongbo Zhang, Fabrice Le Fessant) +- PR#5708: catch Failure"int_of_string" in ocamldebug + (Fabrice Le Fessant, report by user 'schommer') +- PR#5712: (9) new option -bin-annot is not documented + (Damien Doligez, report by Hendrik Tews) +- PR#5731: instruction scheduling forgot to account for destroyed registers + (Xavier Leroy, Benedikt Meurer, reported by Jeffrey Scofield) +- PR#5734: improved Win32 implementation of Unix.gettimeofday + (David Allsopp) +- PR#5735: %apply and %revapply not first class citizens + (Fabrice Le Fessant, reported by Jun Furuse) +- PR#5738: first class module patterns not handled by ocamldep + (Fabrice Le Fessant, Jacques Garrigue, reported by Hongbo Zhang) +- PR#5739: Printf.printf "%F" (-.nan) returns -nan + (Xavier Leroy, David Allsopp, reported by Samuel Mimram) +- PR#5741: make pprintast.ml in compiler_libs + (Alain Frisch, Hongbo Zhang) +- PR#5747: 'unused open' warning not given when compiling with -annot + (Alain Frisch, reported by Valentin Gatien-Baron) +- PR#5752: missing dependencies at byte-code link with mlpack + (Wojciech Meyer, Nicholas Lucaroni) +- PR#5763: ocamlbuild does not give correct flags when running menhir + (Gabriel Scherer, reported by Philippe Veber) +- PR#5765: ocamllex doesn't preserve line directives + (Damien Doligez, reported by Martin Jambon) +- PR#5770: Syntax error messages involving unclosed parens are sometimes + incorrect + (Michel Mauny) +- PR#5772: problem with marshaling of mutually-recursive functions + (Jacques-Henri Jourdan, reported by Cédric Pasteur) +- PR#5775: several bug fixes for tools/pprintast.ml + (Hongbo Zhang) +- PR#5784: -dclambda option is ignored + (Pierre Chambart) +- PR#5785: misbehaviour with abstracted structural type used as GADT index + (Jacques Garrigue, report by Jeremy Yallop) +- PR#5787: Bad behavior of 'Unused ...' warnings in the toplevel + (Alain Frisch) +- PR#5793: integer marshalling is inconsistent between architectures + (Xavier Clerc, report by Pierre-Marie Pédrot) +- PR#5798: add ARM VFPv2 support for Raspbian (ocamlopt) + (Jeffrey Scofield and Anil Madhavapeddy, patch review by Benedikt Meurer) +- PR#5802: Avoiding "let" as a value name + (Jacques Garrigue, report by Tiphaine Turpin) +- PR#5805: Assert failure with warning 34 on pre-processed file + (Alain Frisch, report by Tiphaine Turpin) +- PR#5806: ensure that backtrace tests are always run (testsuite) + (Xavier Clerc, report by user 'michi') +- PR#5809: Generating .cmt files takes a long time, in case of type error + (Alain Frisch) +- PR#5810: error in switch printing when using -dclambda + (Pierre Chambart) +- PR#5811: Untypeast produces singleton tuples for constructor patterns + with only one argument + (Tiphaine Turpin) +- PR#5813: GC not called when unmarshaling repeatedly in a tight loop (ocamlopt) + (Xavier Leroy, report by David Waern) +- PR#5814: read_cmt -annot does not report internal references + (Alain Frisch) +- PR#5815: Multiple exceptions in signatures gives an error + (Leo P. White) +- PR#5816: read_cmt -annot does not work for partial .cmt files + (Alain Frisch) +- PR#5819: segfault when using [with] on large recursive record (ocamlopt) + (Xavier Leroy, Damien Doligez) +- PR#5821: Wrong record field is reported as duplicate + (Alain Frisch, report by Martin Jambon) +- PR#5824: Generate more efficient code for immediate right shifts. + (Pierre Chambart, review by Xavier Leroy) +- PR#5825: Add a toplevel primitive to use source file wrapped with the + coresponding module + (Grégoire Henry, Wojciech Meyer, caml-list discussion) +- PR#5833: README.win32 can leave the wrong flexlink in the path + (Damien Doligez, report by William Smith) +- PR#5835: nonoptional labeled arguments can be passed with '?' + (Jacques Garrigue, report by Elnatan Reisner) +- PR#5840: improved documentation for 'Unix.lseek' + (Xavier Clerc, report by Matej Košík) +- PR#5848: Assertion failure in type checker + (Jacques Garrigue, Alain Frisch, report by David Waern) +- PR#5858: Assert failure during typing of class + (Jacques Garrigue, report by Julien Signoles) +- PR#5865: assert failure when reporting undefined field label + (Jacques Garrigue, report by Anil Madhavapeddy) +- PR#5872: Performance: Buffer.add_char is not inlined + (Gerd Stolpmann, Damien Doligez) +- PR#5876: Uncaught exception with a typing error + (Alain Frisch, Gabriel Scherer, report by Julien Moutinho) +- PR#5877: multiple "open" can become expensive in memory + (Fabrice Le Fessant and Alain Frisch) +- PR#5880: 'Genlex.make_lexer' documention mentions the wrong exception + (Xavier Clerc, report by Virgile Prevosto) +- PR#5885: Incorrect rule for compiling C stubs when shared libraries are not + supported. + (Jérôme Vouillon) +- PR#5891: ocamlbuild: support rectypes tag for mlpack + (Khoo Yit Phang) +- PR#5892: GADT exhaustiveness check is broken + (Jacques Garrigue and Leo P. White) +- PR#5906: GADT exhaustiveness check is still broken + (Jacques Garrigue, report by Sébastien Briais) +- PR#5907: Undetected cycle during typecheck causes exceptions + (Jacques Garrigue, report by Pascal Zimmer) +- PR#5910: Fix code generation bug for "mod 1" on ARM. + (Benedikt Meurer, report by user 'jteg68') +- PR#5911: Signature substitutions fail in submodules + (Jacques Garrigue, report by Markus Mottl) +- PR#5912: add configure option -no-cfi (for OSX 10.6.x with XCode 4.0.2) + (Damien Doligez against XCode versions, report by Thomas Gazagnaire) +- PR#5914: Functor breaks with an equivalent argument signature + (Jacques Garrigue, report by Markus Mottl and Grégoire Henry) +- PR#5920, PR#5957: linking failure for big bytecodes on 32bit architectures + (Benoît Vaugon and Chet Murthy, report by Jun Furuse and Sebastien Mondet) +- PR#5928: Missing space between words in manual page for ocamlmktop + (Damien Doligez, report by Matej Košík) +- PR#5930: ocamldep leaks temporary preprocessing files + (Gabriel Scherer, report by Valentin Gatien-Baron) +- PR#5933: Linking is slow when there are functions with large arities + (Valentin Gatien-Baron, review by Gabriel Scherer) +- PR#5934: integer shift by negative amount (in otherlibs/num) + (Xavier Leroy, report by John Regehr) +- PR#5944: Bad typing performances of big variant type declaration + (Benoît Vaugon) +- PR#5945: Mix-up of Minor_heap_min and Minor_heap_max units + (Benoît Vaugon) +- PR#5948: GADT with polymorphic variants bug + (Jacques Garrigue, report by Leo P. White) +- PR#5953: Unix.system does not handle EINTR + (Jérémie Dimino) +- PR#5965: disallow auto-reference to a recursive module in its definition + (Alain Frisch, report by Arthur Windler via Gabriel Scherer) +- PR#5973: Format module incorrectly parses format string + (Pierre Weis, report by Frédéric Bour) +- PR#5974: better documentation for Str.regexp + (Damien Doligez, report by william) +- PR#5976: crash after recovering from two stack overflows (ocamlopt on MacOS X) + (Xavier Leroy, report by Pierre Boutillier) +- PR#5977: Build failure on raspberry pi: "input_value: integer too large" + (Alain Frisch, report by Sylvain Le Gall) +- PR#5981: Incompatibility check assumes abstracted types are injective + (Jacques Garrigue, report by Jeremy Yallop) +- PR#5982: caml_leave_blocking section and errno corruption + (Jérémie Dimino) +- PR#5985: Unexpected interaction between variance and GADTs + (Jacques Garrigue, Jeremy Yallop and Leo P. White and Gabriel Scherer) +- PR#5988: missing from the documentation: -impl is a valid flag for ocamlopt + (Damien Doligez, report by Vincent Bernardoff) +- PR#5989: Assumed inequalities involving private rows + (Jacques Garrigue, report by Jeremy Yallop) +- PR#5992: Crash when pattern-matching lazy values modifies the scrutinee + (Luc Maranget, Leo P. White) +- PR#5993: Variance of private type abbreviations not checked for modules + (Jacques Garrigue) +- PR#5997: Non-compatibility assumed for concrete types with same constructor + (Jacques Garrigue, report by Gabriel Scherer) +- PR#6004: Type information does not flow to "inherit" parameters + (Jacques Garrigue, report by Alain Frisch) +- PR#6005: Type unsoundness with recursive modules + (Jacques Garrigue, report by Jérémie Dimino and Josh Berdine) +- PR#6010: Big_int.extract_big_int gives wrong results on negative arguments + (Xavier Leroy, report by Drake Wilson via Stéphane Glondu) +- PR#6024: Format syntax for printing @ is incompatible with 3.12.1 + (Damien Doligez, report by Boris Yakobowski) +- PR#6001: Reduce the memory used by compiling Camlp4 + (Hongbo Zhang and Gabriel Scherer, report by Henri Gouraud) +- PR#6031: Camomile problem with -with-frame-pointers + (Fabrice Le Fessant, report by Anil Madhavapeddy) +- PR#6032: better Random.self_init under Windows + (Alain Frisch, Xavier Leroy) +- PR#6033: Matching.inline_lazy_force needs eta-expansion (command-line flags) + (Pierre Chambart, Xavier Leroy and Luc Maranget, + regression report by Gabriel Scherer) +- PR#6046: testsuite picks up the wrong ocamlrun dlls + (Anil Madhavapeddy) +- PR#6056: Using 'match' prevents generalization of values + (Jacques Garrigue, report by Elnatan Reisner) +- PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails + (Gabriel Scherer, report by Hezekiah M. Carty) +- PR#6060: ocamlbuild rules for -principal, -strict-sequence and -short-paths + (Anil Madhavapeddy) +- PR#6069: ocamldoc: lexing: empty token + (Maxence Guesdon, Grégoire Henry, report by ygrek) +- PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly + (Damien Doligez, report by Prashanth Mundkur) +- PR#6074: Wrong error message for failing Condition.broadcast + (Markus Mottl) +- PR#6084: Define caml_modify and caml_initialize as weak symbols to help + with Netmulticore + (Xavier Leroy, Gerd Stolpmann) +- PR#6090: Module constraint + private type seems broken in ocaml 4.01.0 + (Jacques Garrigue, report by Jacques-Pascal Deplaix) +- PR#6109: Typos in ocamlbuild error messages + (Gabriel Kerneis) +- PR#6123: Assert failure when self escapes its class + (Jacques Garrigue, report by whitequark) +- PR#6158: Fatal error using GADTs + (Jacques Garrigue, report by Jeremy Yallop) +- PR#6163: Assert_failure using polymorphic variants in GADTs + (Jacques Garrigue, report by Leo P. White) +- PR#6164: segmentation fault on Num.power_num of 0/1 + (Fabrice Le Fessant, report by Johannes Kanig) + +Feature wishes: +- PR#5181: Merge common floating point constants in ocamlopt + (Benedikt Meurer) +- PR#5243: improve the ocamlbuild API documentation in signatures.mli + (Christophe Troestler) +- PR#5546: moving a function into an internal module slows down its use + (Alain Frisch, report by Fabrice Le Fessant) +- PR#5597: add instruction trace option 't' to OCAMLRUNPARAM + (Anil Madhavapeddy, Wojciech Meyer) +- PR#5676: IPv6 support under Windows + (Jérôme Vouillon, review by Jonathan Protzenko) +- PR#5721: configure -with-frame-pointers for Linux perf profiling + (Fabrice Le Fessant, test by Jérémie Dimino) +- PR#5722: toplevel: print full module path only for first record field + (Jacques Garrigue, report by ygrek) +- PR#5762: Add primitives for fast access to bigarray dimensions + (Pierre Chambart) +- PR#5769: Allow propagation of Sys.big_endian in native code + (Pierre Chambart, stealth commit by Fabrice Le Fessant) +- PR#5771: Add primitives for reading 2, 4, 8 bytes in strings and bigarrays + (Pierre Chambart) +- PR#5774: Add bswap primitives for amd64 and arm + (Pierre Chambart, test by Alain Frisch) +- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64 + (Pierre Chambart) +- PR#5827: provide a dynamic command line parsing mechanism + (Hongbo Zhang) +- PR#5832: patch to improve "wrong file naming" error messages + (William Smith) +- PR#5864: Add a find operation to Set + (François Berenger) +- PR#5886: Small changes to compile for Android + (Jérôme Vouillon, review by Benedikt Meurer) +- PR#5902: -ppx based pre-processor executables accept arguments + (Alain Frisch, report by Wojciech Meyer) +- PR#5986: Protect against marshaling 64-bit integers in bytecode + (Xavier Leroy, report by Alain Frisch) +- PR#6049: support for OpenBSD/macppc platform + (Anil Madhavapeddy, review by Benedikt Meurer) +- PR#6059: add -output-obj rules for ocamlbuild + (Anil Madhavapeddy) + +Tools: +- OCamlbuild now features a bin_annot tag to generate .cmt files. + (Jonathan Protzenko) +- OCamlbuild now features a strict_sequence tag to trigger the + strict-sequence option. + (Jonathan Protzenko) +- OCamlbuild now picks the non-core tools like ocamlfind and menhir from PATH + (Wojciech Meyer) +- PR#5884: Misc minor fixes and cleanup for emacs mode + (Stefan Monnier) +- PR#6030: Improve performance of -annot + (Guillaume Melquiond, Alain Frisch) + + OCaml 4.00.1: ------------- @@ -107,6 +536,10 @@ Standard library: . More random initialization (Random.self_init()), using /dev/urandom when available (e.g. Linux, FreeBSD, MacOS X, Solaris) * Faster implementation of Random.float (changes the generated sequences) +- Format strings for formatted input/output revised to correct PR#5380 + . Consistently treat %@ as a plain @ character + . Consistently treat %% as a plain % character +- Scanf: width and precision for floating point numbers are now handled - Scanf: new function "unescaped" (PR#3888) - Set and Map: more efficient implementation of "filter" and "partition" - String: new function "map" (PR#3888) @@ -183,18 +616,16 @@ Bug Fixes: * PR#5312: command-line arguments @reponsefile auto-expansion feature removed from the Windows OCaml runtime, to avoid conflicts with "-w @..." - PR#5313: ocamlopt -g misses optimizations +- PR#5214: ocamlfind plugin invokes 'cut' utility - PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable - PR#5318: segfault on stack overflow when reading marshaled data - PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation - PR#5322: type abbreviations expanding to a universal type variable -- PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in - another thread - PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode - PR#5330: thread tag with '.top' and '.inferred.mli' targets - PR#5331: ocamlmktop is not always a shell script - PR#5335: Unix.environment segfaults after a call to clearenv - PR#5338: sanitize.sh has windows style end-of-lines (mingw) -- PR#5343: ocaml -rectypes is unsound wrt module subtyping - PR#5344: some predefined exceptions need special printing - PR#5349: Hashtbl.replace uses new key instead of reusing old key - PR#5356: ocamlbuild handling of 'predicates' for ocamlfind @@ -578,7 +1009,7 @@ Bug Fixes: - PR#5018: wrong exception raised by Dynlink.loadfile. - PR#5057: fatal typing error with local module + functor + polymorphic variant - Wrong type for Obj.add_offset. -- Small problem with the representation of Int32, Int64, and Nativeint constants. +- Small problem with representation of Int32, Int64, and Nativeint constants. - Use RTLD_LOCAL for native dynlink in private mode. Objective Caml 3.11.2: @@ -1675,7 +2106,7 @@ Standard library: - Module Printf: added %S and %C formats (quoted, escaped strings and characters); added kprintf (calls user-specified continuation on formatted string). -- Module Queue: faster implementation (courtesy of François Pottier). +- Module Queue: faster implementation (courtesy of Francois Pottier). - Module Random: added Random.bool. - Module Stack: added Stack.is_empty. - Module Pervasives: diff --git a/INSTALL b/INSTALL index 98dfd31d..813f2bf8 100644 --- a/INSTALL +++ b/INSTALL @@ -8,17 +8,6 @@ PREREQUISITES performance. gcc is the standard compiler under Linux, MacOS X, and many other systems. -* Under MacOS X 10.5, you need version 3.1 or later of the XCode - development tools. The version of XCode found on MacOS X 10.5 - installation media causes linking problems. XCode updates - are available free of charge at http://developer.apple.com/tools/xcode/ - -* Under MacOS X up to version 10.2.8, you must raise the limit on the - stack size with one of the following commands: - - limit stacksize 64M # if your shell is zsh or tcsh - ulimit -s 65536 # if your shell is bash - * If you do not have write access to /tmp, you should set the environment variable TMPDIR to the name of some other temporary directory. @@ -141,6 +130,9 @@ The "configure" script accepts the following options: The linker and options to use for producing an object file (rather than an executable) from several other object files. +-no-cfi + Do not compile support for CFI directives. + Examples: Standard installation in /usr/{bin,lib,man} instead of /usr/local: @@ -151,21 +143,22 @@ Examples: or: ./configure -prefix /usr -mandir '$(PREFIX)/man/manl' - On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host, - to build a 64-bit version of OCaml: - ./configure -cc "gcc -m64" - - On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml: - ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c" - On a Linux x86/64 bits host, to build a 32-bit version of OCaml: - ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" + ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" \ + -host i386-linux -partialld "ld -r -melf_i386" On a Linux x86/64 bits host, to build the run-time system in PIC mode (enables putting the runtime in a shared library, at a small performance cost): ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC" + On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host, + to build a 64-bit version of OCaml: + ./configure -cc "gcc -m64" + + On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml: + ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c" + For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" @@ -347,3 +340,7 @@ system. The "configure" script tries to work around this problem. unable to compile correctly the runtime system (wrong code is generated for (x - y) where x is a pointer and y an integer). Fix: use gcc. + +* Under MacOS X 10.6, with XCode 4.0.2, the configure script mistakenly +detects support for CFI directives in the assembler. +Fix: give the "-no-cfi" option to configure. diff --git a/Makefile b/Makefile index c2003d34..10c80d2f 100644 --- a/Makefile +++ b/Makefile @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile 12929 2012-09-17 16:23:06Z doligez $ - # The main Makefile include config/Makefile @@ -19,7 +17,7 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS= -strict-sequence -warn-error A $(INCLUDES) +COMPFLAGS=-strict-sequence -w +33..39 -warn-error A $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -43,7 +41,9 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ - parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo + parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ + parsing/pprintast.cmo \ + parsing/ast_mapper.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ @@ -52,9 +52,10 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ - typing/mtype.cmo typing/includecore.cmo \ + typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ - typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ + typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -63,7 +64,8 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ - driver/pparse.cmo driver/main_args.cmo + driver/pparse.cmo driver/main_args.cmo \ + driver/compenv.cmo driver/compmisc.cmo COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) @@ -279,8 +281,11 @@ install: cd stdlib; $(MAKE) install cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) - cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) + cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ + toplevel/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ + $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge$(EXE) cp toplevel/topdirs.cmi $(LIBDIR) cd tools; $(MAKE) install @@ -314,12 +319,13 @@ installoptopt: cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ - compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ - compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ - $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ - $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ - $(COMPLIBDIR) - cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a ocamloptcomp.a + compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ + compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ + $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ + $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ + $(COMPLIBDIR) + cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ + ocamloptcomp.a clean:: partialclean @@ -338,8 +344,8 @@ partialclean:: rm -f compilerlibs/ocamlbytecomp.cma ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) - $(CAMLC) $(LINKFLAGS) -o ocamlc \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) + $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \ + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -353,7 +359,7 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) + compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh @@ -368,10 +374,11 @@ compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) partialclean:: rm -f compilerlibs/ocamltoplevel.cma -ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge +ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ - compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) + compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) rm -f ocaml.tmp @@ -414,6 +421,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \ + -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -459,10 +467,11 @@ compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a -ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) +ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ - compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ - $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -477,10 +486,11 @@ compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a -ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) +ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ - compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ - $(OPTSTART:.cmo=.cmx) + compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + $(OPTSTART:.cmo=.cmx) @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh @@ -579,9 +589,10 @@ tools/cvt_emit: tools/cvt_emit.mll # The "expunge" utility -expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo - $(CAMLC) $(LINKFLAGS) -o expunge \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo +expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + toplevel/expunge.cmo + $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \ + compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge @@ -727,13 +738,17 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native ./build/camlp4-native-only.sh # Ocamlbuild - +#ifeq ($(OCAMLBUILD_NOBOOT),"yes") +#ocamlbuild.byte: ocamlc +# $(MAKE) -C ocamlbuild -f Makefile.noboot +#else ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot ./build/ocamlbuild-byte-only.sh +#endif -ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot +ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt ./build/ocamlbuild-native-only.sh -ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot +ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt ./build/ocamlbuildlib-native-only.sh ocamlbuild-mixed-boot: ocamlc @@ -795,6 +810,7 @@ alldepend:: depend distclean: ./build/distclean.sh + rm -f ocaml ocamlcomp.sh testsuite/_log .PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart diff --git a/Makefile.nt b/Makefile.nt index d62e0ecf..41d9c4a8 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile.nt 12750 2012-07-20 08:06:01Z doligez $ - # The main Makefile include config/Makefile @@ -40,19 +38,21 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ - parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo + parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ + parsing/pprintast.cmo \ + parsing/ast_mapper.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ - typing/typedtree.cmo typing/ctype.cmo \ + typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ - typing/mtype.cmo typing/includecore.cmo \ - typing/includemod.cmo typing/parmatch.cmo \ - typing/typetexp.cmo \ - typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ + typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ + typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ + typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -61,7 +61,8 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ - driver/pparse.cmo driver/main_args.cmo + driver/pparse.cmo driver/main_args.cmo \ + driver/compenv.cmo driver/compmisc.cmo COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) @@ -74,7 +75,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/compilenv.cmo \ + asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ @@ -96,7 +97,7 @@ OPTSTART=driver/optmain.cmo TOPLEVELSTART=toplevel/topstart.cmo -PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree +PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop # For users who don't read the INSTALL file defaultentry: @@ -215,8 +216,11 @@ installbyt: cd stdlib ; $(MAKEREC) install cp lex/ocamllex $(BINDIR)/ocamllex.exe cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe - cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) + cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ + toplevel/*.cmi $(COMPLIBDIR) + cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ + $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge.exe cp toplevel/topdirs.cmi $(LIBDIR) cd tools ; $(MAKEREC) install @@ -248,9 +252,11 @@ installoptopt: cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ - compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ - compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ - $(COMPLIBDIR) + compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ + compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ + $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \ + $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \ + $(COMPLIBDIR) clean:: partialclean @@ -269,8 +275,8 @@ partialclean:: rm -f compilerlibs/ocamlbytecomp.cma ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) - $(CAMLC) $(LINKFLAGS) -o ocamlc \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) + $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc compilerlibs/ocamlcommon.cma \ + compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh @@ -302,7 +308,8 @@ compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) partialclean:: rm -f compilerlibs/ocamltoplevel.cma -ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge +ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) @@ -315,7 +322,8 @@ partialclean:: # The native toplevel ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall + $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ + $(NATTOPOBJS:.cmo=.cmx) -linkall toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa @@ -350,6 +358,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|false|' \ + -e 's|%%WITH_FRAME_POINTERS%%|false|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -396,7 +405,8 @@ compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) -ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) +ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @@ -414,7 +424,8 @@ compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) -ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) +ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ + $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) @@ -520,9 +531,10 @@ tools/cvt_emit: tools/cvt_emit.mll # The "expunge" utility -expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo - $(CAMLC) $(LINKFLAGS) -o expunge \ - compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo +expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ + toplevel/expunge.cmo + $(CAMLC) $(LINKFLAGS) -o expunge compilerlibs/ocamlcommon.cma \ + compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge @@ -651,6 +663,11 @@ ocamlbuild-mixed-boot: partialclean:: rm -rf _build +# Make clean in the test suite + +clean:: + cd testsuite; $(MAKE) clean + # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/README b/README index eb9f8c39..06591e23 100644 --- a/README +++ b/README @@ -129,7 +129,3 @@ To be effective, bug reports should include a complete program configuration you are using (machine type, etc). You can also contact the implementors directly at caml@inria.fr. - - ----- -$Id: README 12149 2012-02-10 16:15:24Z doligez $ diff --git a/README.win32 b/README.win32 index ddd010a0..00006dd4 100644 --- a/README.win32 +++ b/README.win32 @@ -87,7 +87,7 @@ THIRD-PARTY SOFTWARE: http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". -[2] flexdll version 0.29 or later. +[2] flexdll version 0.31 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html [3] TCL/TK version 8.5. Windows binaries are available as part of the @@ -106,7 +106,7 @@ You will need the following software components to perform the recompilation: compiling on a 64-bit Windows. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ Install at least the following packages (and their dependencies): - diffutils, make, ncurses. + diffutils, dos2unix, gcc-core, make, ncurses. First, you need to set up your cygwin environment for using the MS tools. The following assumes that you have installed [1], [2], and [3] @@ -395,7 +395,7 @@ THIRD-PARTY SOFTWARE: http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". -[2] flexdll version 0.29 or later. +[2] flexdll version 0.31 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html @@ -425,7 +425,7 @@ to adjust the paths accordingly. echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv - echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv + echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv diff --git a/Upgrading b/Upgrading deleted file mode 100644 index 808413ed..00000000 --- a/Upgrading +++ /dev/null @@ -1,109 +0,0 @@ - - FAQ: how to upgrade from Objective Caml 3.02 to 3.03 - -I Installation - -Q1: When compiling the distribution, I am getting strange linking - errors in "otherlibraries". - -A1: This is probably a problem with dynamic linking. You can disable - it with ./configure -no-shared-libs. If you really want to use - shared libraries, look in the manual pages of your system for how - to get some debugging output from the dynamic linker. - -II Non-label changes - -Q2: I get a syntax error when I try to compile a program using stream - parsers. - -A2: Stream parser now require camlp4. It is included in the - distribution, and you just need to use "ocamlc -pp camlp4o" in - place of "ocamlc". You can also use it under the toplevel with - #load"camlp4o.cma". - -Q3: I get a warning when I use the syntax "#variant" inside type - expressions. - -A3: The new syntax is [< variant], which just a special case of - the more general new syntax, which allows type expressions like - [ variant1 | variant2] or [> variant]. See the reference manual - for details. - -III Label changes - -Q4: I was using labels before, and now I get lots of type errors. - -A4: The handling of labels changed with 3.03-alpha. The new default - is a more flexible version of the commuting label mode, allowing - one to omit labels in total applications. There is still a - -nolabels mode, but it does not allow non-optional labels in - applications (this was unsound). - To keep full compatibility with Objective Caml 2, labels were - removed from the standard libraries. Some labelized libraries are - kept as StdLabels (contains Array, List and String), MoreLabels - (contains Hashtbl, Map and Set), and UnixLabels. - Note that MoreLabels' status is not yet decided. - -Q5: Why isn't there a ThreadUnixLabels module ? - -A5: ThreadUnix is deprecated. It only calls directly the Unix module. - -Q6: I was using commuting label mode, how can I upgrade ? - -A6: The new behaviour is compatible with commuting label mode, but - standard libraries have no labels. You can add the following - lines at the beginning of your files (according to your needs): - open Stdlabels - open MoreLabels - module Unix = UnixLabels - Alternatively, if you already have a common module opened by - everybody, you can add these: - include StdLabels - include MoreLabels - module Unix = UnixLabels - - You will then need to remove labels in functions from other modules. - This can be automated by using the scrapelabels tool, installed - in the Objective Caml library directory, which both removes labels - and inserts needed `open' clauses (see -help for details). - $CAMLLIB/scrapelabels -keepstd *.ml - or - $CAMLLIB/scrapelabels -keepmore *.ml - Note that scrapelabels is not guaranteed to be sound for commuting - label programs, since it will just remove labels, and not reorder - arguments. - -Q7: I was using a few labels in classic mode, and now I get all these - errors. I just want to get rid of all these silly labels. - -A7: scrapelabels will do it for you. - $CAMLLIB/scrapelabels [-all] *.ml - $CAMLLIB/scrapelabels -intf *.mli - You should specify the -all option only if you are sure that your - sources do not contain calls to functions with optional - parameters, as those labels would also be removed. - -Q8: I was using labels in classic mode, and I was actually pretty fond - of them. How much more labels will I have to write now ? How can I - convert my programs and libraries ? - -A8: The new default mode is more flexible than the original commuting - mode, so that you shouldn't see too much differences when using - labeled libraries. Labels are only compulsory in partial - applications (including the special case of function with an - unknown return type), or if you wrote some of them. - - On the other hand, for definitions, labels present in the - interface must also be present in the implementation. - The addlabels tool can help you to do that. Suppose that you have - mymod.ml and mymod.mli, where mymod.mli adds some labels. Then - doing - $CAMLLIB/addlabels mymod.ml - will insert labels from the interface inside the implementation. - It also takes care of inserting them in recursive calls, as - the return type of the function is not known while typing it. - - If you used labels from standard libraries, you will also have - problems with them. You can proceed as described in A6. Since you - used classic mode, you do not need to bother about changed - argument order. diff --git a/VERSION b/VERSION index 5457d75b..d6ae7090 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,4 @@ -4.00.1 +4.01.0 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli - -# $Id: VERSION 12983 2012-10-03 15:11:00Z doligez $ diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index c4e5efb4..b0a5ffb8 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *) - (* Machine-specific command-line options *) let pic_code = ref true @@ -40,6 +38,9 @@ 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 *) + | Isqrtf (* Float square root *) + | Ifloatsqrtf of addressing_mode (* Float square root from memory *) and float_operation = Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv @@ -51,6 +52,8 @@ let size_addr = 8 let size_int = 8 let size_float = 8 +let allow_unaligned_access = true + (* Behavior of division *) let division_crashes_on_overflow = true @@ -104,6 +107,11 @@ let print_specific_operation printreg op ppf arg = fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n + | Isqrtf -> + fprintf ppf "sqrtf %a" printreg arg.(0) + | Ifloatsqrtf addr -> + fprintf ppf "sqrtf float64[%a]" + (print_addressing printreg addr) [|arg.(0)|] | Ifloatarithmem(op, addr) -> let op_name = function | Ifloatadd -> "+f" @@ -113,3 +121,5 @@ let print_specific_operation printreg op ppf arg = fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op) (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1)) + | Ibswap i -> + fprintf ppf "bswap_%i %a" i printreg arg.(0) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 0f476e73..8dad2206 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12907 2012-09-08 16:51:03Z xleroy $ *) - (* Emission of x86-64 (AMD 64) assembly code *) -open Misc open Cmm open Arch open Proc @@ -26,6 +23,8 @@ open Emitaux let macosx = (Config.system = "macosx") let mingw64 = (Config.system = "mingw64") +let fp = Config.with_frame_pointers + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -35,12 +34,13 @@ let stack_offset = ref 0 (* Layout of the stack frame *) let frame_required () = - !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 + fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 let frame_size () = (* includes return address *) if frame_required() then begin let sz = - (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) + (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8 + + (if fp then 8 else 0) ) in Misc.align sz 16 end else !stack_offset + 8 @@ -110,13 +110,13 @@ let emit_reg = function let reg_low_8_name = [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; - "%r12b"; "%r13b"; "%bpl"; "%r10b"; "%r11b" |] + "%r12b"; "%r13b"; "%r10b"; "%r11b"; "%bpl" |] let reg_low_16_name = [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; - "%r12w"; "%r13w"; "%bp"; "%r10w"; "%r11w" |] + "%r12w"; "%r13w"; "%r10w"; "%r11w"; "%bp" |] let reg_low_32_name = [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; - "%r12d"; "%r13d"; "%ebp"; "%r10d"; "%r11d" |] + "%r12d"; "%r13d"; "%r10d"; "%r11d"; "%ebp" |] let emit_subreg tbl r = match r.loc with @@ -291,25 +291,25 @@ let emit_float_test cmp neg arg lbl = ` jp {emit_label lbl}\n`; (* branch taken if unordered *) ` jne {emit_label lbl}\n` (* branch taken if xy *) | (Clt, _) -> - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) + ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) if not neg then ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) + ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) else ` jb {emit_label lbl}\n` (* taken if unordered or y - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; + ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; if not neg then ` ja {emit_label lbl}\n` (* branch taken if x>y *) else ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) | (Cge, _) -> - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) + ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if x>=y *) else @@ -319,9 +319,12 @@ let emit_float_test cmp neg arg lbl = let output_epilogue f = if frame_required() then begin - let n = frame_size() - 8 in + let n = frame_size() - 8 - (if fp then 8 else 0) in ` addq ${emit_int n}, %rsp\n`; cfi_adjust_cfa_offset (-n); + if fp then begin + ` popq %rbp\n` + end; f (); (* reset CFA back cause function body may continue *) cfi_adjust_cfa_offset n @@ -329,6 +332,23 @@ let output_epilogue f = else f () +(* Floating-point constants *) + +let float_constants = ref ([] : (string * int) list) + +let add_float_constant cst = + try + List.assoc cst !float_constants + with + Not_found -> + let lbl = new_label() in + float_constants := (cst, lbl) :: !float_constants; + lbl + +let emit_float_constant (cst, lbl) = + `{emit_label lbl}:`; + emit_float64_directive ".quad" cst + (* Output the assembly code for an instruction *) (* Name of current function *) @@ -336,8 +356,6 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -let float_constants = ref ([] : (int * string) list) - (* Emit an instruction *) let emit_instr fallthrough i = emit_debug_info i.dbg; @@ -368,8 +386,7 @@ let emit_instr fallthrough i = | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + let lbl = add_float_constant s in ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> @@ -546,6 +563,22 @@ let emit_instr fallthrough i = ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ifloatarithmem(op, addr))) -> ` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Ibswap size)) -> + begin match size with + | 16 -> + ` xchg %ah, %al\n`; + ` movzwq {emit_reg16 i.res.(0)}, {emit_reg i.res.(0)}\n` + | 32 -> + ` bswap {emit_reg32 i.res.(0)}\n`; + ` movslq {emit_reg32 i.res.(0)}, {emit_reg i.res.(0)}\n` + | 64 -> + ` bswap {emit_reg i.res.(0)}\n` + | _ -> assert false + end + | Lop(Ispecific Isqrtf) -> + ` sqrtsd {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Ifloatsqrtf addr)) -> + ` sqrtsd {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` | Lreloadretaddr -> () | Lreturn -> @@ -658,12 +691,6 @@ let rec emit_all fallthrough i = emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next -(* Emission of the floating-point constants *) - -let emit_float_constant (lbl, cst) = - `{emit_label lbl}:`; - emit_float64_directive ".quad" cst - (* Emission of the profiling prelude *) let emit_profile () = @@ -675,7 +702,8 @@ let emit_profile () = need to preserve other regs. We do need to initialize rbp like mcount expects it, though. *) ` pushq %r10\n`; - ` movq %rsp, %rbp\n`; + if not fp then + ` movq %rsp, %rbp\n`; ` {emit_call "mcount"}\n`; ` popq %r10\n` | _ -> @@ -688,7 +716,6 @@ let fundecl fundecl = fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; - float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; @@ -704,9 +731,14 @@ let fundecl fundecl = `{emit_symbol fundecl.fun_name}:\n`; emit_debug_info fundecl.fun_dbg; cfi_startproc (); + if fp then begin + ` pushq %rbp\n`; + cfi_adjust_cfa_offset 8; + ` movq %rsp, %rbp\n`; + end; if !Clflags.gprofile then emit_profile(); if frame_required() then begin - let n = frame_size() - 8 in + let n = frame_size() - 8 - (if fp then 8 else 0) in ` subq ${emit_int n}, %rsp\n`; cfi_adjust_cfa_offset n; end; @@ -720,15 +752,6 @@ let fundecl fundecl = ` .type {emit_symbol fundecl.fun_name},@function\n`; ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` | _ -> () - end; - if !float_constants <> [] then begin - if macosx then - ` .literal8\n` - else if mingw64 then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata.cst8,\"a\",@progbits\n`; - List.iter emit_float_constant !float_constants end (* Emission of data *) @@ -771,6 +794,7 @@ let data l = let begin_assembly() = reset_debug_info(); (* PR#5603 *) + float_constants := []; if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) if macosx then @@ -795,6 +819,15 @@ let begin_assembly() = if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = + if !float_constants <> [] then begin + if macosx then + ` .literal8\n` + else if mingw64 then + ` .section .rdata,\"dr\"\n` + else + ` .section .rodata.cst8,\"a\",@progbits\n`; + List.iter emit_float_constant !float_constants + end; let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 9980efb9..c38c21f2 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -10,12 +10,10 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp 12907 2012-09-08 16:51:03Z xleroy $ *) - (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) module StringSet = - Set.Make(struct type t = string let compare = compare end) + Set.Make(struct type t = string let compare (x:t) y = compare x y end) open Misc open Cmm @@ -110,13 +108,13 @@ let emit_reg = function let reg_low_8_name = [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; - "r12b"; "r13b"; "bpl"; "r10b"; "r11b" |] + "r12b"; "r13b"; "r10b"; "r11b"; "bpl" |] let reg_low_16_name = [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; - "r12w"; "r13w"; "bp"; "r10w"; "r11w" |] + "r12w"; "r13w"; "r10w"; "r11w"; "bp" |] let reg_low_32_name = [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; - "r12d"; "r13d"; "ebp"; "r10d"; "r11d" |] + "r12d"; "r13d"; "r10d"; "r11d"; "ebp" |] let emit_subreg tbl pref r = match r.loc with @@ -320,6 +318,39 @@ let output_epilogue () = ` add rsp, {emit_int n}\n` end +(* Floating-point constants *) + +let float_constants = ref ([] : (string * int) list) + +let add_float_constant cst = + try + List.assoc cst !float_constants + with + Not_found -> + let lbl = new_label() in + float_constants := (cst, lbl) :: !float_constants; + lbl + +let emit_float s = + (* MASM doesn't like floating-point constants such as 2e9. + Turn them into 2.0e9. *) + let pos_e = ref (-1) and pos_dot = ref (-1) in + for i = 0 to String.length s - 1 do + match s.[i] with + 'e'|'E' -> pos_e := i + | '.' -> pos_dot := i + | _ -> () + done; + if !pos_dot < 0 && !pos_e >= 0 then begin + emit_string (String.sub s 0 !pos_e); + emit_string ".0"; + emit_string (String.sub s !pos_e (String.length s - !pos_e)) + end else + emit_string s + +let emit_float_constant (cst, lbl) = + `{emit_label lbl} REAL8 {emit_float cst}\n` + (* Output the assembly code for an instruction *) (* Name of current function *) @@ -327,8 +358,6 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -let float_constants = ref ([] : (int * string) list) - let emit_instr fallthrough i = match i.desc with Lend -> () @@ -361,8 +390,7 @@ let emit_instr fallthrough i = | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + let lbl = add_float_constant s in ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -539,6 +567,22 @@ let emit_instr fallthrough i = ` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n` | Lop(Ispecific(Ifloatarithmem(op, addr))) -> ` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n` + | Lop(Ispecific(Ibswap size)) -> + begin match size with + | 16 -> + ` xchg ah, al\n`; + ` movzx {emit_reg i.res.(0)}, {emit_reg16 i.res.(0)}\n` + | 32 -> + ` bswap {emit_reg32 i.res.(0)}\n`; + ` movsxd {emit_reg i.res.(0)}, {emit_reg32 i.res.(0)}\n` + | 64 -> + ` bswap {emit_reg i.res.(0)}\n` + | _ -> assert false + end + | Lop(Ispecific Isqrtf) -> + ` sqrtsd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific(Ifloatsqrtf addr)) -> + ` sqrtsd {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 0}\n` | Lreloadretaddr -> () | Lreturn -> @@ -639,28 +683,6 @@ let rec emit_all fallthrough i = emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next -(* Emission of the floating-point constants *) - -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - -let emit_float_constant (lbl, cst) = - `{emit_label lbl} REAL8 {emit_float cst}\n` - (* Emission of a function declaration *) let fundecl fundecl = @@ -668,7 +690,6 @@ let fundecl fundecl = fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; - float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; @@ -684,11 +705,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - emit_call_bound_errors(); - if !float_constants <> [] then begin - ` .DATA\n`; - List.iter emit_float_constant !float_constants - end + emit_call_bound_errors() (* Emission of data *) @@ -731,6 +748,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + float_constants := []; ` EXTRN caml_young_ptr: QWORD\n`; ` EXTRN caml_young_limit: QWORD\n`; ` EXTRN caml_exception_pointer: QWORD\n`; @@ -756,6 +774,10 @@ let begin_assembly() = `{emit_symbol lbl_begin} LABEL QWORD\n` let end_assembly() = + if !float_constants <> [] then begin + ` .DATA\n`; + List.iter emit_float_constant !float_constants + end; let lbl_end = Compilenv.make_symbol (Some "code_end") in add_def_symbol lbl_end; ` .CODE\n`; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index bc95fe68..8774a0da 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: proc.ml 12907 2012-09-08 16:51:03Z xleroy $ *) - (* Description of the AMD64 processor *) open Misc @@ -20,6 +18,8 @@ open Cmm open Reg open Mach +let fp = Config.with_frame_pointers + (* Which ABI to use *) let win64 = @@ -47,9 +47,9 @@ let masm = r9 7 r12 8 r13 9 - rbp 10 - r10 11 - r11 12 + r10 10 + r11 11 + rbp 12 r14 trap pointer r15 allocation pointer @@ -79,10 +79,10 @@ let int_reg_name = match Config.ccomp_type with | "msvc" -> [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; - "r12"; "r13"; "rbp"; "r10"; "r11" |] + "r12"; "r13"; "r10"; "r11"; "rbp" |] | _ -> [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; - "%r12"; "%r13"; "%rbp"; "%r10"; "%r11" |] + "%r12"; "%r13"; "%r10"; "%r11"; "%rbp" |] let float_reg_name = match Config.ccomp_type with @@ -135,6 +135,7 @@ let phys_reg n = let rax = phys_reg 0 let rcx = phys_reg 5 let rdx = phys_reg 4 +let rbp = phys_reg 12 let rxmm15 = phys_reg 115 let stack_slot slot ty = @@ -244,12 +245,12 @@ let destroyed_at_c_call = if win64 then (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *) Array.of_list(List.map phys_reg - [0;4;5;6;7;11;12; + [0;4;5;6;7;10;11; 100;101;102;103;104;105]) else (* Unix: rbp, rbx, r12-r15 preserved *) Array.of_list(List.map phys_reg - [0;2;3;4;5;6;7;11;12; + [0;2;3;4;5;6;7;10;11; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115]) @@ -261,23 +262,36 @@ let destroyed_at_oper = function | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] - | _ -> [||] + | _ -> + if fp then +(* prevent any use of the frame pointer ! *) + [| rbp |] + else + [||] + let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) + let safe_register_pressure = function - Iextcall(_,_) -> if win64 then 8 else 0 - | _ -> 11 + Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0 + | _ -> if fp then 10 else 11 let max_register_pressure = function - Iextcall(_, _) -> if win64 then [| 8; 10 |] else [| 4; 0 |] - | Iintop(Idiv | Imod) -> [| 11; 16 |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) - -> [| 12; 16 |] - | Istore(Single, _) -> [| 13; 15 |] - | _ -> [| 13; 16 |] + Iextcall(_, _) -> + if win64 then + if fp then [| 7; 10 |] else [| 8; 10 |] + else + if fp then [| 3; 0 |] else [| 4; 0 |] + | Iintop(Idiv | Imod) -> + if fp then [| 10; 16 |] else [| 11; 16 |] + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> + if fp then [| 11; 16 |] else [| 12; 16 |] + | Istore(Single, _) -> + if fp then [| 12; 15 |] else [| 13; 15 |] + | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] (* Layout of the stack frame *) @@ -294,3 +308,9 @@ let assemble_file infile outfile = else Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + +let init () = + if fp then begin + num_available_registers.(0) <- 12 + end else + num_available_registers.(0) <- 13 diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 50a28d2c..510f201f 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Cmm open Arch open Reg diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml index fba88766..e234431b 100644 --- a/asmcomp/amd64/scheduling.ml +++ b/asmcomp/amd64/scheduling.ml @@ -10,9 +10,7 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *) - -open Schedgen (* to create a dependency *) +let _ = let module M = Schedgen in () (* to create a dependency *) (* Scheduling is turned off because the processor schedules dynamically much better than what we could do. *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 8e75baae..4de84128 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -10,15 +10,11 @@ (* *) (***********************************************************************) -(* $Id: selection.ml 12122 2012-02-04 10:00:09Z bmeurer $ *) - (* Instruction selection for the AMD64 *) -open Misc open Arch open Proc open Cmm -open Reg open Mach (* Auxiliary for recognizing addressing modes *) @@ -88,8 +84,13 @@ let pseudoregs_for_operation op arg res = ([|res.(0); arg.(1)|], res) (* One-address unary operations: arg.(0) and res.(0) must be the same *) | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) - | Iabsf | Inegf -> + | Iabsf | Inegf + | Ispecific(Ibswap (32|64)) -> (res, res) + (* For xchg, args must be a register allowing access to high 8 bit register + (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) + | Ispecific(Ibswap 16) -> + ([| rax |], [| rax |]) | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); @@ -111,6 +112,10 @@ let pseudoregs_for_operation op arg res = (* Other instructions are regular *) | _ -> raise Use_default +let inline_ops = + [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; + "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] + (* The selector class *) class selector = object (self) @@ -121,6 +126,15 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n +method! is_simple_expr e = + match e with + | Cop(Cextcall(fn, _, _, _), args) + when List.mem fn inline_ops -> + (* inlined ops are simple if their arguments are *) + List.for_all self#is_simple_expr args + | _ -> + super#is_simple_expr e + method select_addressing chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) @@ -186,6 +200,16 @@ method! select_operation op args = self#select_floatarith true Imulf Ifloatmul args | Cdivf -> self#select_floatarith false Idivf Ifloatdiv args + | Cextcall("sqrt", _, false, _) -> + begin match args with + [Cop(Cload (Double|Double_u as chunk), [loc])] -> + let (addr, arg) = self#select_addressing chunk loc in + (Ispecific(Ifloatsqrtf addr), [arg]) + | [arg] -> + (Ispecific Isqrtf, [arg]) + | _ -> + assert false + end (* Recognize store instructions *) | Cstore Word -> begin match args with @@ -196,6 +220,13 @@ method! select_operation op args = | _ -> super#select_operation op args end + | Cextcall("caml_bswap16_direct", _, _, _) -> + (Ispecific (Ibswap 16), args) + | Cextcall("caml_int32_direct_bswap", _, _, _) -> + (Ispecific (Ibswap 32), args) + | Cextcall("caml_int64_direct_bswap", _, _, _) + | Cextcall("caml_nativeint_direct_bswap", _, _, _) -> + (Ispecific (Ibswap 64), args) | _ -> super#select_operation op args (* Recognize float arithmetic with mem *) diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index a275b32b..cac286aa 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -11,21 +11,18 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *) - (* Specific operations for the ARM processor *) -open Misc open Format -type abi = EABI | EABI_VFP +type abi = EABI | EABI_HF type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7 -type fpu = Soft | VFPv3_D16 | VFPv3 +type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3 let abi = match Config.system with "linux_eabi" -> EABI - | "linux_eabihf" -> EABI_VFP + | "linux_eabihf" -> EABI_HF | _ -> assert false let string_of_arch = function @@ -38,6 +35,7 @@ let string_of_arch = function let string_of_fpu = function Soft -> "soft" + | VFPv2 -> "vfpv2" | VFPv3_D16 -> "vfpv3-d16" | VFPv3 -> "vfpv3" @@ -47,13 +45,14 @@ let (arch, fpu, thumb) = let (def_arch, def_fpu, def_thumb) = begin match abi, Config.model with (* Defaults for architecture, FPU and Thumb *) - EABI, "armv5" -> ARMv5, Soft, false - | EABI, "armv5te" -> ARMv5TE, Soft, false - | EABI, "armv6" -> ARMv6, Soft, false - | EABI, "armv6t2" -> ARMv6T2, Soft, false - | EABI, "armv7" -> ARMv7, Soft, false - | EABI, _ -> ARMv4, Soft, false - | EABI_VFP, _ -> ARMv7, VFPv3_D16, true + EABI, "armv5" -> ARMv5, Soft, false + | EABI, "armv5te" -> ARMv5TE, Soft, false + | EABI, "armv6" -> ARMv6, Soft, false + | EABI, "armv6t2" -> ARMv6T2, Soft, false + | EABI, "armv7" -> ARMv7, Soft, false + | EABI, _ -> ARMv4, Soft, false + | EABI_HF, "armv6" -> ARMv6, VFPv2, false + | EABI_HF, _ -> ARMv7, VFPv3_D16, true end in (ref def_arch, ref def_fpu, ref def_thumb) @@ -61,19 +60,20 @@ let pic_code = ref false let farch spec = arch := (match spec with - "armv4" when abi <> EABI_VFP -> ARMv4 - | "armv5" when abi <> EABI_VFP -> ARMv5 - | "armv5te" when abi <> EABI_VFP -> ARMv5TE - | "armv6" when abi <> EABI_VFP -> ARMv6 - | "armv6t2" when abi <> EABI_VFP -> ARMv6T2 - | "armv7" -> ARMv7 + "armv4" when abi <> EABI_HF -> ARMv4 + | "armv5" when abi <> EABI_HF -> ARMv5 + | "armv5te" when abi <> EABI_HF -> ARMv5TE + | "armv6" -> ARMv6 + | "armv6t2" -> ARMv6T2 + | "armv7" -> ARMv7 | spec -> raise (Arg.Bad spec)) let ffpu spec = fpu := (match spec with - "soft" when abi <> EABI_VFP -> Soft - | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16 - | "vfpv3" when abi = EABI_VFP -> VFPv3 + "soft" when abi <> EABI_HF -> Soft + | "vfpv2" when abi = EABI_HF -> VFPv2 + | "vfpv3-d16" when abi = EABI_HF -> VFPv3_D16 + | "vfpv3" when abi = EABI_HF -> VFPv3 | spec -> raise (Arg.Bad spec)) let command_line_options = @@ -110,14 +110,15 @@ type specific_operation = Ishiftarith of arith_operation * int | Ishiftcheckbound of int | Irevsubimm of int - | Imuladd (* multiply and add *) - | Imulsub (* multiply and subtract *) - | Inegmulf (* floating-point negate and multiply *) - | Imuladdf (* floating-point multiply and add *) - | Inegmuladdf (* floating-point negate, multiply and add *) - | Imulsubf (* floating-point multiply and subtract *) - | Inegmulsubf (* floating-point negate, multiply and subtract *) - | Isqrtf (* floating-point square root *) + | Imuladd (* multiply and add *) + | Imulsub (* multiply and subtract *) + | Inegmulf (* floating-point negate and multiply *) + | Imuladdf (* floating-point multiply and add *) + | Inegmuladdf (* floating-point negate, multiply and add *) + | Imulsubf (* floating-point multiply and subtract *) + | Inegmulsubf (* floating-point negate, multiply and subtract *) + | Isqrtf (* floating-point square root *) + | Ibswap of int (* endianess conversion *) and arith_operation = Ishiftadd @@ -132,6 +133,8 @@ 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 @@ -206,6 +209,9 @@ let print_specific_operation printreg op ppf arg = | Isqrtf -> fprintf ppf "sqrtf %a" printreg arg.(0) + | Ibswap n -> + fprintf ppf "bswap%i %a" n + printreg arg.(0) (* Recognize immediate operands *) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 8bec1730..4a126151 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -11,11 +11,8 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *) - (* Emission of ARM assembly code *) -open Location open Misc open Cmm open Arch @@ -402,6 +399,10 @@ let emit_instr i = ` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`; 2 end + | Lop(Iconst_float f) when !fpu = VFPv2 -> + let lbl = float_literal f in + ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + 1 | Lop(Iconst_float f) -> let encode imm = let sg = Int64.to_int (Int64.shift_right_logical imm 63) in @@ -468,7 +469,7 @@ let emit_instr i = let ninstr = emit_stack_adjustment (-n) in stack_offset := !stack_offset + n; ninstr - | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 -> + | Lop(Iload(Single, addr)) when !fpu >= VFPv2 -> ` flds s14, {emit_addressing addr i.arg 0}\n`; ` fcvtds {emit_reg i.res.(0)}, s14\n`; 2 | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft -> @@ -502,7 +503,7 @@ let emit_instr i = | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 -> + | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> @@ -681,6 +682,16 @@ let emit_instr i = | Imulsub -> "mls" | _ -> assert false) 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`; 1 + | Lop(Ispecific(Ibswap size)) -> + begin match size with + 16 -> + ` rev16 {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; + ` movt {emit_reg i.res.(0)}, #0\n`; 2 + | 32 -> + ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1 + | _ -> + assert false + end | Lreloadretaddr -> let n = frame_size() in ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 @@ -808,7 +819,7 @@ let rec emit_all ninstr i = let n = emit_instr i in let ninstr' = ninstr + n in (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *) - let limit = (if !fpu >= VFPv3_D16 && !float_literals <> [] + let limit = (if !fpu >= VFPv2 && !float_literals <> [] then 127 else 511) in let limit = limit - !num_literals in @@ -910,6 +921,7 @@ let begin_assembly() = end; begin match !fpu with Soft -> ` .fpu softvfp\n` + | VFPv2 -> ` .fpu vfpv2\n` | VFPv3_D16 -> ` .fpu vfpv3-d16\n` | VFPv3 -> ` .fpu vfpv3\n` end; diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 35fdc8ff..dbb13173 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: proc.ml 12125 2012-02-05 08:47:16Z bmeurer $ *) - (* Description of the ARM processor *) open Misc @@ -38,7 +36,7 @@ let word_addressed = false r13 stack pointer r14 return address r15 program counter - Floatinng-point register map (VFPv3): + 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 @@ -55,9 +53,9 @@ let float_reg_name = (* We have three register classes: 0 for integer registers - 1 for VFPv3-D16 + 1 for VFPv2 and VFPv3-D16 2 for VFPv3 - This way we can choose between VFPv3-D16 and VFPv3 + This way we can choose between VFPv2/VFPv3-D16 and VFPv3 at (ocamlopt) runtime using command line switches. *) @@ -66,6 +64,7 @@ let num_register_classes = 3 let register_class r = match (r.typ, !fpu) with (Int | Addr), _ -> 0 + | Float, VFPv2 -> 1 | Float, VFPv3_D16 -> 1 | Float, _ -> 2 @@ -124,8 +123,8 @@ let calling_conventions ofs := !ofs + size_int end | Float -> - assert (abi = EABI_VFP); - assert (!fpu >= VFPv3_D16); + assert (abi = EABI_HF); + assert (!fpu >= VFPv2); if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float @@ -186,24 +185,24 @@ let destroyed_at_c_call = 108;109;110;111;112;113;114;115; 116;116;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] - | EABI_VFP -> (* r4-r7, d8-d15 preserved *) + | EABI_HF -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; 116;116;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ ) + Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Ialloc n) -> + | Iop(Ialloc _) -> destroyed_at_alloc | Iop(Iconst_symbol _) when !pic_code -> - [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *) + [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> - [|phys_reg 107|] (* d7 (s14-s15) destroyed *) + [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -211,11 +210,17 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 5 + Iextcall(_, _) -> if abi = EABI then 0 else 4 + | Ialloc _ -> if abi = EABI then 0 else 7 + | Iconst_symbol _ when !pic_code -> 7 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> [| 5; 9; 9 |] + Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] + | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] + | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] + | Iintoffloat | Ifloatofint + | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] | _ -> [| 9; 16; 32 |] (* Layout of the stack *) @@ -228,3 +233,6 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + + +let init () = () diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml index 7789790c..bd783acb 100644 --- a/asmcomp/arm/reload.ml +++ b/asmcomp/arm/reload.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Reloading for the ARM *) let fundecl f = diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index 703b02f1..9e2d65bc 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml 12125 2012-02-05 08:47:16Z bmeurer $ *) - open Arch open Mach @@ -42,7 +40,7 @@ method oper_latency = function | Imulf | Ispecific Inegmulf | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) | Ispecific Isqrtf - | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2 + | Inegf | Iabsf when !fpu >= VFPv2 -> 2 (* Everything else *) | _ -> 1 @@ -72,7 +70,7 @@ method oper_issue_cycles = function | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17 | Idivf | Ispecific Isqrtf -> 27 - | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4 + | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv2 -> 4 (* Everything else *) | _ -> 1 diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index ecda3829..97f615ec 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -11,22 +11,18 @@ (* *) (***********************************************************************) -(* $Id: selection.ml 12125 2012-02-05 08:47:16Z bmeurer $ *) - (* Instruction selection for the ARM processor *) open Arch +open Proc open Cmm open Mach -open Misc -open Proc -open Reg let is_offset chunk n = match chunk with - (* VFPv3 load/store have -1020 to 1020 *) + (* VFPv{2,3} load/store have -1020 to 1020 *) Single | Double | Double_u - when !fpu >= VFPv3_D16 -> + when !fpu >= VFPv2 -> n >= -1020 && n <= 1020 (* ARM load/store byte/word have -4095 to 4095 *) | Byte_unsigned | Byte_signed @@ -61,7 +57,7 @@ let pseudoregs_for_operation op arg res = (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) - (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *) + (* VFPv{2,3} Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *) | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); @@ -95,7 +91,12 @@ method is_immediate n = method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 -> + | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 -> + List.for_all self#is_simple_expr args + (* inlined byte-swap ops are simple if their arguments are *) + | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + List.for_all self#is_simple_expr args + | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e @@ -173,14 +174,20 @@ method! select_operation op args = | (Cdivi, args) -> (Iextcall("__aeabi_idiv", false), args) | (Cmodi, [arg; Cconst_int n]) - when n = 1 lsl Misc.log2 n -> + when n > 1 && n = 1 lsl Misc.log2 n -> (Iintop_imm(Imod, n), [arg]) | (Cmodi, args) -> (* See above for fix up of return register *) (Iextcall("__aeabi_idivmod", false), args) + (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *) + | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + (Ispecific(Ibswap 16), args) + (* Recognize 32-bit bswap instructions (ARMv6 and above) *) + | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 -> + (Ispecific(Ibswap 32), args) (* Turn floating-point operations into runtime ABI calls for softfp *) | (op, args) when !fpu = Soft -> self#select_operation_softfp op args - (* Select operations for VFPv3 *) + (* Select operations for VFPv{2,3} *) | (op, args) -> self#select_operation_vfpv3 op args method private select_operation_softfp op args = diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index f152bb3f..40f7dafb 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: asmgen.ml 12202 2012-03-07 17:50:17Z frisch $ *) - (* From lambda to assembly code *) open Format @@ -37,6 +35,9 @@ let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase +let clambda_dump_if ppf ulambda = + if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda + let rec regalloc ppf round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ @@ -56,6 +57,7 @@ let rec regalloc ppf round fd = let (++) x f = f x let compile_fundecl (ppf : formatter) fd_cmm = + Proc.init (); Reg.reset(); fd_cmm ++ Selection.fundecl @@ -104,6 +106,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) = Emitaux.output_channel := oc; Emit.begin_assembly(); Closure.intro size lam + ++ clambda_dump_if ppf ++ Cmmgen.compunit size ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); (match toplevel with None -> () | Some f -> compile_genfuns ppf f); diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 9c1b01ac..33582af4 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: asmgen.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* From lambda to assembly code *) val compile_implementation : diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index f6424ec6..140791f2 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: asmlibrarian.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Build libraries of .cmx files *) open Misc @@ -53,7 +51,7 @@ let create_archive file_list lib_name = let infos = { lib_units = descr_list; lib_ccobjs = !Clflags.ccobjs; - lib_ccopts = !Clflags.ccopts } in + lib_ccopts = !Clflags.all_ccopts } in output_value outchan infos; if Ccomp.create_archive archive_name objfile_list <> 0 then raise(Error(Archiver_error archive_name)); diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli index 692947cf..c1a6a478 100644 --- a/asmcomp/asmlibrarian.mli +++ b/asmcomp/asmlibrarian.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: asmlibrarian.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Build libraries of .cmx files *) open Format diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 33eaa3f1..f6a85a94 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml 12201 2012-03-07 17:40:17Z frisch $ *) - (* Link a set of .cmx/.o files and produce an executable *) -open Sys open Misc open Config open Cmx_format @@ -260,7 +257,7 @@ let link_shared ppf objfiles output_name = (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; - Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; + Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; let objfiles = List.rev (List.map object_file_name objfiles) @ (List.rev !Clflags.ccobjs) in @@ -318,7 +315,8 @@ let link ppf objfiles output_name = (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; - Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) + Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; + (* put user's opts first *) let startup = if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index db4e9ab8..1cf9e302 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: asmlink.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Link a set of .cmx/.o files and produce an executable or a plugin *) open Format diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 530fbe26..1a4fe902 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -10,19 +10,14 @@ (* *) (***********************************************************************) -(* $Id: asmpackager.ml 12202 2012-03-07 17:50:17Z frisch $ *) - (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -open Printf open Misc -open Lambda -open Clambda open Cmx_format type error = - Illegal_renaming of string * string + Illegal_renaming of string * string * string | Forward_reference of string * string | Wrong_for_pack of string * string | Linking_error @@ -41,14 +36,14 @@ type pack_member = pm_name: string; pm_kind: pack_member_kind } -let read_member_info pack_path file = +let read_member_info pack_path file = ( let name = String.capitalize(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmx" then begin let (info, crc) = Compilenv.read_unit_info file in if info.ui_name <> name - then raise(Error(Illegal_renaming(file, info.ui_name))); + then raise(Error(Illegal_renaming(name, file, info.ui_name))); if info.ui_symbol <> (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name then raise(Error(Wrong_for_pack(file, pack_path))); @@ -58,6 +53,7 @@ let read_member_info pack_path file = end else PM_intf in { pm_file = file; pm_name = name; pm_kind = kind } +) (* Check absence of forward references *) @@ -192,9 +188,10 @@ let package_files ppf files targetcmx = open Format let report_error ppf = function - Illegal_renaming(file, id) -> - fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" - Location.print_filename file id + Illegal_renaming(name, file, id) -> + fprintf ppf "Wrong file naming: %a@ contains the code for\ + @ %s when %s was expected" + Location.print_filename file name id | Forward_reference(file, ident) -> fprintf ppf "Forward reference to %s in file %a" ident Location.print_filename file diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index e4f39801..65272b7e 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -10,15 +10,13 @@ (* *) (***********************************************************************) -(* $Id: asmpackager.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) val package_files: Format.formatter -> string list -> string -> unit type error = - Illegal_renaming of string * string + Illegal_renaming of string * string * string | Forward_reference of string * string | Wrong_for_pack of string * string | Linking_error diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index e05c3c08..dd53020d 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: clambda.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index a7d33db2..737965db 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: clambda.mli 12179 2012-02-21 17:41:02Z xleroy $ *) - (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index f0e23fa8..dc4c73ad 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: closure.ml 12800 2012-07-30 18:59:07Z doligez $ *) - (* Introduction of closures, uncurrying, recognition of direct calls *) open Misc @@ -192,6 +190,15 @@ let rec is_pure_clambda = function let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) +let make_comparison cmp (x: int) (y: int) = + make_const_bool + (match cmp with + Ceq -> x = y + | Cneq -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y) let simplif_prim_pure p (args, approxs) dbg = match approxs with @@ -199,6 +206,9 @@ let simplif_prim_pure p (args, approxs) dbg = begin match p with Pidentity -> make_const_int x | Pnegint -> make_const_int (-x) + | Pbswap16 -> + make_const_int (((x land 0xff) lsl 8) lor + ((x land 0xff00) lsr 8)) | Poffsetint y -> make_const_int (x + y) | _ -> (Uprim(p, args, dbg), Value_unknown) end @@ -215,15 +225,7 @@ let simplif_prim_pure p (args, approxs) dbg = | Plslint -> make_const_int(x lsl y) | Plsrint -> make_const_int(x lsr y) | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> - let result = match cmp with - Ceq -> x = y - | Cneq -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y in - make_const_bool result + | Pintcomp cmp -> make_comparison cmp x y | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x] -> @@ -231,12 +233,32 @@ let simplif_prim_pure p (args, approxs) dbg = Pidentity -> make_const_ptr x | Pnot -> make_const_bool(x = 0) | Pisint -> make_const_bool true + | Pctconst c -> + begin + match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + end | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x; Value_constptr y] -> begin match p with Psequand -> make_const_bool(x <> 0 && y <> 0) | Psequor -> make_const_bool(x <> 0 || y <> 0) + | Pintcomp cmp -> make_comparison cmp x y + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + | [Value_constptr x; Value_integer y] -> + begin match p with + | Pintcomp cmp -> make_comparison cmp x y + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + | [Value_integer x; Value_constptr y] -> + begin match p with + | Pintcomp cmp -> make_comparison cmp x y | _ -> (Uprim(p, args, dbg), Value_unknown) end | _ -> @@ -335,7 +357,8 @@ let rec substitute sb ulam = id in Uassign(id', substitute sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg) + Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, + dbg) (* Perform an inline expansion *) @@ -489,9 +512,11 @@ let rec close fenv cenv = function | Lconst cst -> begin match cst with Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) - | Const_base(Const_char c) -> (Uconst (cst,None), Value_integer(Char.code c)) + | Const_base(Const_char c) -> (Uconst (cst,None), + Value_integer(Char.code c)) | Const_pointer n -> (Uconst (cst, None), Value_constptr n) - | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown) + | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), + Value_unknown) end | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct @@ -515,8 +540,9 @@ let rec close fenv cenv = function when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> (Ident.create "arg", arg) ) uargs in - let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ -> - Ident.create "arg")) in + let final_args = + Array.to_list (Array.init (fundesc.fun_arity - nargs) + (fun _ -> Ident.create "arg")) in let rec iter args body = match args with [] -> body @@ -614,7 +640,8 @@ let rec close fenv cenv = function match approx with Value_tuple a when n < Array.length a -> a.(n) | _ -> Value_unknown in - check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox + check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) + fieldapprox | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in (!global_approx).(n) <- approx; diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli index 209c5b0e..e7bccbca 100644 --- a/asmcomp/closure.mli +++ b/asmcomp/closure.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: closure.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 96fa1caf..941b0142 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmm.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - type machtype_component = Addr | Int diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index b3a1cbe2..202b6aec 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmm.mli 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Second intermediate language (machine independent) *) type machtype_component = diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 3f54da0e..23d47983 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.ml 12800 2012-07-30 18:59:07Z doligez $ *) - (* Translation from closed lambda to C-- *) open Misc @@ -78,7 +76,10 @@ let int_const n = (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) let add_const c n = - if n = 0 then c else Cop(Caddi, [c; Cconst_int n]) + if n = 0 then c + else match c with + | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) + | c -> Cop(Caddi, [c; Cconst_int n]) let incr_int = function Cconst_int n when n < max_int -> Cconst_int(n+1) @@ -155,10 +156,25 @@ let lsl_int c1 c2 = Cop(Clsl, [c1; c2]) let ignore_low_bit_int = function - Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c + Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0 + -> c | Cop(Cor, [c; Cconst_int 1]) -> c | c -> c +let lsr_int c1 c2 = + match c2 with + (Cconst_int n) when n > 0 -> + Cop(Clsr, [ignore_low_bit_int c1; c2]) + | _ -> + Cop(Clsr, [c1; c2]) + +let asr_int c1 c2 = + match c2 with + (Cconst_int n) when n > 0 -> + Cop(Casr, [ignore_low_bit_int c1; c2]) + | _ -> + Cop(Casr, [c1; c2]) + (* Division or modulo on tagged integers. The overflow case min_int / -1 cannot occur, but we must guard against division by zero. *) @@ -423,21 +439,27 @@ type rhs_kind = | RHS_floatblock of int | RHS_nonrec ;; -let rec expr_size = function +let rec expr_size env = function + | Uvar id -> + begin try Ident.find_same id env with Not_found -> RHS_nonrec end | Uclosure(fundecls, clos_vars) -> RHS_block (fundecls_size fundecls + List.length clos_vars) | Ulet(id, exp, body) -> - expr_size body + expr_size (Ident.add id (expr_size env exp) env) body | Uletrec(bindings, body) -> - expr_size body + expr_size env body | Uprim(Pmakeblock(tag, mut), args, _) -> RHS_block (List.length args) | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) + | Uprim (Pduprecord (Record_regular, sz), _, _) -> + RHS_block sz + | Uprim (Pduprecord (Record_float, sz), _, _) -> + RHS_floatblock sz | Usequence(exp, exp') -> - expr_size exp' + expr_size env exp' | _ -> RHS_nonrec (* Record application and currying functions *) @@ -627,7 +649,8 @@ let bigarray_get unsafe elt_kind layout b args dbg = Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) + (fun addr -> box_complex (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) @@ -642,7 +665,8 @@ let bigarray_set unsafe elt_kind layout b args newval dbg = let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) + (fun addr -> Csequence( Cop(Cstore kind, [addr; complex_re newv]), Cop(Cstore kind, @@ -651,6 +675,158 @@ let bigarray_set unsafe elt_kind layout b args newval dbg = Cop(Cstore (bigarray_word_kind elt_kind), [bigarray_indexing unsafe elt_kind layout b args dbg; newval])) +let unaligned_load_16 ptr idx = + if Arch.allow_unaligned_access + then Cop(Cload Sixteen_unsigned, [add_int ptr idx]) + else + let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in + let v2 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1)]) in + let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in + Cop(Cor, [lsl_int b1 (Cconst_int 8); b2]) + +let unaligned_set_16 ptr idx newval = + if Arch.allow_unaligned_access + then Cop(Cstore Sixteen_unsigned, [add_int ptr idx; newval]) + else + let v1 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in + let v2 = Cop(Cand, [newval; Cconst_int 0xFF]) in + let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in + Csequence( + Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1); b2])) + +let unaligned_load_32 ptr idx = + if Arch.allow_unaligned_access + then Cop(Cload Thirtytwo_unsigned, [add_int ptr idx]) + else + let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in + let v2 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1)]) in + let v3 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 2)]) in + let v4 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 3)]) in + let b1, b2, b3, b4 = + if Arch.big_endian + then v1, v2, v3, v4 + else v4, v3, v2, v1 in + Cop(Cor, + [Cop(Cor, [lsl_int b1 (Cconst_int 24); lsl_int b2 (Cconst_int 16)]); + Cop(Cor, [lsl_int b3 (Cconst_int 8); b4])]) + +let unaligned_set_32 ptr idx newval = + if Arch.allow_unaligned_access + then Cop(Cstore Thirtytwo_unsigned, [add_int ptr idx; newval]) + else + let v1 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 24]); Cconst_int 0xFF]) in + let v2 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 16]); Cconst_int 0xFF]) in + let v3 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in + let v4 = Cop(Cand, [newval; Cconst_int 0xFF]) in + let b1, b2, b3, b4 = + if Arch.big_endian + then v1, v2, v3, v4 + else v4, v3, v2, v1 in + Csequence( + Csequence( + Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1); b2])), + Csequence( + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 2); b3]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 3); b4]))) + +let unaligned_load_64 ptr idx = + assert(size_int = 8); + if Arch.allow_unaligned_access + then Cop(Cload Word, [add_int ptr idx]) + else + let v1 = Cop(Cload Byte_unsigned, [add_int ptr idx]) in + let v2 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1)]) in + let v3 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 2)]) in + let v4 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 3)]) in + let v5 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 4)]) in + let v6 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 5)]) in + let v7 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 6)]) in + let v8 = Cop(Cload Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 7)]) in + let b1, b2, b3, b4, b5, b6, b7, b8 = + if Arch.big_endian + then v1, v2, v3, v4, v5, v6, v7, v8 + else v8, v7, v6, v5, v4, v3, v2, v1 in + Cop(Cor, + [Cop(Cor, + [Cop(Cor, [lsl_int b1 (Cconst_int (8*7)); + lsl_int b2 (Cconst_int (8*6))]); + Cop(Cor, [lsl_int b3 (Cconst_int (8*5)); + lsl_int b4 (Cconst_int (8*4))])]); + Cop(Cor, + [Cop(Cor, [lsl_int b5 (Cconst_int (8*3)); + lsl_int b6 (Cconst_int (8*2))]); + Cop(Cor, [lsl_int b7 (Cconst_int 8); + b8])])]) + +let unaligned_set_64 ptr idx newval = + assert(size_int = 8); + if Arch.allow_unaligned_access + then Cop(Cstore Word, [add_int ptr idx; newval]) + else + let v1 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*7)]); Cconst_int 0xFF]) in + let v2 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*6)]); Cconst_int 0xFF]) in + let v3 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*5)]); Cconst_int 0xFF]) in + let v4 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*4)]); Cconst_int 0xFF]) in + let v5 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*3)]); Cconst_int 0xFF]) in + let v6 = + Cop(Cand, [Cop(Clsr, [newval; Cconst_int (8*2)]); Cconst_int 0xFF]) in + let v7 = Cop(Cand, [Cop(Clsr, [newval; Cconst_int 8]); Cconst_int 0xFF]) in + let v8 = Cop(Cand, [newval; Cconst_int 0xFF]) in + let b1, b2, b3, b4, b5, b6, b7, b8 = + if Arch.big_endian + then v1, v2, v3, v4, v5, v6, v7, v8 + else v8, v7, v6, v5, v4, v3, v2, v1 in + Csequence( + Csequence( + Csequence( + Cop(Cstore Byte_unsigned, [add_int ptr idx; b1]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 1); b2])), + Csequence( + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 2); b3]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 3); b4]))), + Csequence( + Csequence( + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 4); b5]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 5); b6])), + Csequence( + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 6); b7]), + Cop(Cstore Byte_unsigned, + [add_int (add_int ptr idx) (Cconst_int 7); b8])))) + +let check_bound unsafe dbg a1 a2 k = + if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + (* Simplification of some primitives into C calls *) let default_prim name = @@ -688,6 +864,11 @@ let simplif_primitive_32bits = function Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) + | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64") + | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64") + | Pbigstring_load_64(_) -> Pccall (default_prim "caml_ba_uint8_get64") + | Pbigstring_set_64(_) -> Pccall (default_prim "caml_ba_uint8_set64") + | Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap") | p -> p let simplif_primitive p = @@ -711,8 +892,6 @@ let simplif_primitive p = let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) -exception Found of int - let make_switch_gen arg cases acts = let lcases = Array.length cases in let new_cases = Array.create lcases 0 in @@ -801,7 +980,12 @@ let is_unboxed_number = function Boxed_float | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32 | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64 - | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint + | Pbigarrayref(_, _, Pbigarray_native_int,_) -> Boxed_integer Pnativeint + | Pstring_load_32(_) -> Boxed_integer Pint32 + | Pstring_load_64(_) -> Boxed_integer Pint64 + | Pbigstring_load_32(_) -> Boxed_integer Pint32 + | Pbigstring_load_64(_) -> Boxed_integer Pint64 + | Pbbswap bi -> Boxed_integer bi | _ -> No_unboxing end | _ -> No_unboxing @@ -937,7 +1121,8 @@ let rec transl = function (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), List.map transl_unbox_float args)) else - Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg), + Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, + dbg), List.map transl args) | (Pmakearray kind, []) -> transl_constant(Const_block(0, [])) @@ -979,6 +1164,9 @@ let rec transl = function | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval | _ -> untag_int (transl argnewval)) dbg) + | (Pbigarraydim(n), [b]) -> + let dim_ofs = 4 + n in + tag_int (Cop(Cload Word, [field_address (transl b) dim_ofs])) | (p, [arg]) -> transl_prim_1 p arg dbg | (p, [arg1; arg2]) -> @@ -1107,11 +1295,22 @@ and transl_prim_1 p arg dbg = (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) + | Pctconst c -> + let const_of_bool b = tag_int (Cconst_int (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)) + | Ostype_unix -> const_of_bool (Sys.os_type = "Unix") + | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin") + end | Poffsetint n -> if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) Debuginfo.none + transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) + Debuginfo.none | Poffsetref n -> return_unit (bind "ref" (transl arg) (fun arg -> @@ -1162,6 +1361,18 @@ and transl_prim_1 p arg dbg = box_int bi2 (transl_unbox_int bi1 arg) | Pnegbint bi -> box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg])) + | Pbbswap bi -> + let prim = match bi with + | Pnativeint -> "nativeint" + | Pint32 -> "int32" + | Pint64 -> "int64" in + box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, + typ_int, false, Debuginfo.none), + [transl_unbox_int bi arg])) + | Pbswap16 -> + tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, + Debuginfo.none), + [untag_int (transl arg)])) | _ -> fatal_error "Cmmgen.transl_prim_1" @@ -1170,7 +1381,7 @@ and transl_prim_2 p arg1 arg2 dbg = (* Heap operations *) Psetfield(n, ptr) -> if ptr then - return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), + return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), [field_address (transl arg1) n; transl arg2])) else return_unit(set_field (transl arg1) n (transl arg2)) @@ -1199,9 +1410,11 @@ and transl_prim_2 p arg1 arg2 dbg = | Pmulint -> incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) + tag_int(safe_divmod Cdivi (untag_int(transl arg1)) + (untag_int(transl arg2)) dbg) | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) + tag_int(safe_divmod Cmodi (untag_int(transl arg1)) + (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1213,10 +1426,10 @@ and transl_prim_2 p arg1 arg2 dbg = | Plslint -> incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2))) | Plsrint -> - Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]); + Cop(Cor, [lsr_int (transl arg1) (untag_int(transl arg2)); Cconst_int 1]) | Pasrint -> - Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]); + Cop(Cor, [asr_int (transl arg1) (untag_int(transl arg2)); Cconst_int 1]) | Pintcomp cmp -> tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) @@ -1251,6 +1464,54 @@ and transl_prim_2 p arg1 arg2 dbg = make_checkbound dbg [string_length str; idx], Cop(Cload Byte_unsigned, [add_int str idx]))))) + | Pstring_load_16(unsafe) -> + tag_int + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1)) + idx (unaligned_load_16 str idx)))) + + | Pbigstring_load_16(unsafe) -> + tag_int + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 1)) idx + (unaligned_load_16 ba_data idx))))) + + | Pstring_load_32(unsafe) -> + box_int Pint32 + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3)) + idx (unaligned_load_32 str idx)))) + + | Pbigstring_load_32(unsafe) -> + box_int Pint32 + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 3)) idx + (unaligned_load_32 ba_data idx))))) + + | Pstring_load_64(unsafe) -> + box_int Pint64 + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7)) + idx (unaligned_load_64 str idx)))) + + | Pbigstring_load_64(unsafe) -> + box_int Pint64 + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 7)) idx + (unaligned_load_64 ba_data idx))))) + (* Array operations *) | Parrayrefu kind -> begin match kind with @@ -1284,15 +1545,16 @@ and transl_prim_2 p arg1 arg2 dbg = float_array_ref arr idx))))) | Paddrarray | Pintarray -> bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [addr_array_length(header arr); idx], - addr_array_ref arr idx))) + bind "arr" (transl arg1) (fun arr -> + Csequence(make_checkbound dbg [addr_array_length(header arr); idx], + addr_array_ref arr idx))) | Pfloatarray -> box_float( bind "index" (transl arg2) (fun idx -> - bind "arr" (transl arg1) (fun arr -> - Csequence(make_checkbound dbg [float_array_length(header arr); idx], - unboxed_float_array_ref arr idx)))) + bind "arr" (transl arg1) (fun arr -> + Csequence(make_checkbound dbg + [float_array_length(header arr); idx], + unboxed_float_array_ref arr idx)))) end (* Operations on bitvects *) @@ -1420,6 +1682,61 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = Csequence(make_checkbound dbg [float_array_length(header arr);idx], float_array_set arr idx newval)))) end) + + | Pstring_set_16(unsafe) -> + return_unit + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (untag_int (transl arg3)) (fun newval -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 1)) + idx (unaligned_set_16 str idx newval))))) + + | Pbigstring_set_16(unsafe) -> + return_unit + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (untag_int (transl arg3)) (fun newval -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 1)) + idx (unaligned_set_16 ba_data idx newval)))))) + + | Pstring_set_32(unsafe) -> + return_unit + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (transl_unbox_int Pint32 arg3) (fun newval -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3)) + idx (unaligned_set_32 str idx newval))))) + + | Pbigstring_set_32(unsafe) -> + return_unit + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (transl_unbox_int Pint32 arg3) (fun newval -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 3)) + idx (unaligned_set_32 ba_data idx newval)))))) + + | Pstring_set_64(unsafe) -> + return_unit + (bind "str" (transl arg1) (fun str -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (transl_unbox_int Pint64 arg3) (fun newval -> + check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7)) + idx (unaligned_set_64 str idx newval))))) + + | Pbigstring_set_64(unsafe) -> + return_unit + (bind "ba" (transl arg1) (fun ba -> + bind "index" (untag_int (transl arg2)) (fun idx -> + bind "newval" (transl_unbox_int Pint64 arg3) (fun newval -> + bind "ba_data" (Cop(Cload Word, [field_address ba 1])) (fun ba_data -> + check_bound unsafe dbg (sub_int (Cop(Cload Word,[field_address ba 5])) + (Cconst_int 7)) idx + (unaligned_set_64 ba_data idx newval)))))) + | _ -> fatal_error "Cmmgen.transl_prim_3" @@ -1434,7 +1751,7 @@ and transl_unbox_int bi = function Cconst_natint n | Uconst(Const_base(Const_int64 n), _) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i),_)], _) when bi = bi' -> + | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) @@ -1557,7 +1874,8 @@ and transl_switch arg index cases = match Array.length cases with (Array.of_list !inters) actions) and transl_letrec bindings cont = - let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in + let bsz = + List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in let op_alloc prim sz = Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in let rec init_blocks = function @@ -1599,7 +1917,7 @@ let transl_function f = module StringSet = Set.Make(struct type t = string - let compare = compare + let compare (x:t) y = compare x y end) let rec transl_all_functions already_translated cont = @@ -1974,14 +2292,21 @@ let tuplify_function arity = clos clos1.vars[1]) (app clos.direct clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos))) + Special "shortcut" functions are also generated to handle the case where a partially applied function is applied to all remaining arguments in one go. For instance: (defun caml_curry_N_1_app (arg2 ... argN clos) (let clos' clos.vars[1] (app clos'.direct clos.vars[0] arg2 ... argN clos'))) + + Those shortcuts may lead to a quadratic number of application + primitives being generated in the worst case, which resulted in + linking time blowup in practice (PR#5933), so we only generate and + use them when below a fixed arity 'max_arity_optimized'. *) +let max_arity_optimized = 15 let final_curry_function arity = let last_arg = Ident.create "arg" in let last_clos = Ident.create "clos" in @@ -1991,7 +2316,7 @@ let final_curry_function arity = get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) else - if n = arity - 1 then + if n = arity - 1 || arity > max_arity_optimized then begin let newclos = Ident.create "clos" in Clet(newclos, @@ -2023,7 +2348,7 @@ let rec intermediate_curry_functions arity num = {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = - if arity - num > 2 then + if arity - num > 2 && arity <= max_arity_optimized then Cop(Calloc, [alloc_closure_header 5; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); @@ -2038,7 +2363,7 @@ let rec intermediate_curry_functions arity num = fun_fast = true; fun_dbg = Debuginfo.none } :: - (if arity - num > 2 then + (if arity <= max_arity_optimized && arity - num > 2 then let rec iter i = if i <= arity then let arg = Ident.create (Printf.sprintf "arg%d" i) in @@ -2079,7 +2404,7 @@ let curry_function arity = module IntSet = Set.Make( struct type t = int - let compare = compare + let compare (x:t) y = compare x y end) let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 51a949e0..84db405f 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Translation from closed lambda to C-- *) val compunit: int -> Clambda.ulambda -> Cmm.phrase list diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index b7debe1e..c4e55796 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmx_format.mli 12800 2012-07-30 18:59:07Z doligez $ *) - (* Format of .cmx, .cmxa and .cmxs files *) (* Each .o file has a matching .cmx file that provides the following infos @@ -30,7 +28,7 @@ type unit_infos = mutable ui_defines: string list; (* Unit and sub-units implemented *) mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) - mutable ui_approx: Clambda.value_approximation; (* Approx of the structure *) + mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) mutable ui_send_fun: int list; (* Send functions needed *) diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml index ff2c4c18..a3182462 100644 --- a/asmcomp/codegen.ml +++ b/asmcomp/codegen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: codegen.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* From C-- to assembly code *) open Format diff --git a/asmcomp/codegen.mli b/asmcomp/codegen.mli index c3adc1cd..5dab12fc 100644 --- a/asmcomp/codegen.mli +++ b/asmcomp/codegen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: codegen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* From C-- to assembly code *) val phrase: Cmm.phrase -> unit diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index b9581f55..67ed8729 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -10,269 +10,214 @@ (* *) (***********************************************************************) -(* $Id: coloring.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Register allocation by coloring of the interference graph *) -open Reg +module OrderedRegSet = + Set.Make(struct + type t = Reg.t + let compare r1 r2 = + let open Reg in + let c1 = r1.spill_cost and d1 = r1.degree in + let c2 = r2.spill_cost and d2 = r2.degree in + let n = c2 * d1 - c1 * d2 in + if n <> 0 then n else + let n = c2 - c1 in + if n <> 0 then n else + let n = d1 - d2 in + if n <> 0 then n else r1.stamp - r2.stamp + end) -(* Preallocation of spilled registers in the stack. *) +open Reg -let allocate_spilled reg = - if reg.spill then begin - let cl = Proc.register_class reg in - let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in - List.iter - (fun r -> - match r.loc with - Stack(Local n) -> - if Proc.register_class r = cl then conflict.(n) <- true - | _ -> ()) - reg.interf; - let slot = ref 0 in - while !slot < nslots && conflict.(!slot) do incr slot done; - reg.loc <- Stack(Local !slot); - if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1 - end +let allocate_registers() = -(* Compute the degree (= number of neighbours of the same type) - of each register, and split them in two sets: - unconstrained (degree < number of available registers) - and constrained (degree >= number of available registers). - Spilled registers are ignored in the process. *) + (* Constrained regs with degree >= number of available registers, + sorted by spill cost (highest first). + The spill cost measure is [r.spill_cost / r.degree]. + [r.spill_cost] estimates the number of accesses to [r]. *) + let constrained = ref OrderedRegSet.empty in -let unconstrained = ref Reg.Set.empty -let constrained = ref Reg.Set.empty + (* Unconstrained regs with degree < number of available registers *) + let unconstrained = ref [] in -let find_degree reg = - if reg.spill then () else begin + (* Preallocate the spilled registers in the stack. + Split the remaining registers into constrained and unconstrained. *) + let remove_reg reg = let cl = Proc.register_class reg in - let avail_regs = Proc.num_available_registers.(cl) in - if avail_regs = 0 then - (* Don't bother computing the degree if there are no regs - in this class *) - unconstrained := Reg.Set.add reg !unconstrained - else begin - let deg = ref 0 in + if reg.spill then begin + (* Preallocate the registers in the stack *) + let nslots = Proc.num_stack_slots.(cl) in + let conflict = Array.create nslots false in List.iter - (fun r -> if not r.spill && Proc.register_class r = cl then incr deg) + (fun r -> + match r.loc with + Stack(Local n) -> + if Proc.register_class r = cl then conflict.(n) <- true + | _ -> ()) reg.interf; - reg.degree <- !deg; - if !deg >= avail_regs - then constrained := Reg.Set.add reg !constrained - else unconstrained := Reg.Set.add reg !unconstrained - end - end - -(* Remove a register from the interference graph *) - -let remove_reg reg = - reg.degree <- 0; (* 0 means r is no longer part of the graph *) - let cl = Proc.register_class reg in - List.iter - (fun r -> - if Proc.register_class r = cl && r.degree > 0 then begin - let olddeg = r.degree in - r.degree <- olddeg - 1; - if olddeg = Proc.num_available_registers.(cl) then begin - (* r was constrained and becomes unconstrained *) - constrained := Reg.Set.remove r !constrained; - unconstrained := Reg.Set.add r !unconstrained - end - end) - reg.interf - -(* Remove all registers one by one, unconstrained if possible, otherwise - constrained with lowest spill cost. Return the list of registers removed - in reverse order. - The spill cost measure is [r.spill_cost / r.degree]. - [r.spill_cost] estimates the number of accesses to this register. *) - -let rec remove_all_regs stack = - if not (Reg.Set.is_empty !unconstrained) then begin - (* Pick any unconstrained register *) - let r = Reg.Set.choose !unconstrained in - unconstrained := Reg.Set.remove r !unconstrained; - remove_all_regs (r :: stack) - end else - if not (Reg.Set.is_empty !constrained) then begin - (* Find a constrained reg with minimal cost *) - let r = ref Reg.dummy in - let min_degree = ref 0 and min_spill_cost = ref 1 in - (* initially !min_spill_cost / !min_degree is +infty *) - Reg.Set.iter - (fun r2 -> - (* if r2.spill_cost / r2.degree < !min_spill_cost / !min_degree *) - if r2.spill_cost * !min_degree < !min_spill_cost * r2.degree - then begin - r := r2; min_degree := r2.degree; min_spill_cost := r2.spill_cost - end) - !constrained; - constrained := Reg.Set.remove !r !constrained; - remove_all_regs (!r :: stack) - end else - stack (* All regs have been removed *) - -(* Iterate over all registers preferred by the given register (transitively) *) - -let iter_preferred f reg = - let rec walk r w = - if not r.visited then begin - f r w; - begin match r.prefer with - [] -> () - | p -> r.visited <- true; - List.iter (fun (r1, w1) -> walk r1 (min w w1)) p; - r.visited <- false - end + let slot = ref 0 in + while !slot < nslots && conflict.(!slot) do incr slot done; + reg.loc <- Stack(Local !slot); + if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1 + end else if reg.degree < Proc.num_available_registers.(cl) then + unconstrained := reg :: !unconstrained + else begin + constrained := OrderedRegSet.add reg !constrained end in - reg.visited <- true; - List.iter (fun (r, w) -> walk r w) reg.prefer; - reg.visited <- false - -(* Where to start the search for a suitable register. - Used to introduce some "randomness" in the choice between registers - with equal scores. This offers more opportunities for scheduling. *) - -let start_register = Array.create Proc.num_register_classes 0 -(* Assign a location to a register, the best we can *) - -let assign_location reg = - let cl = Proc.register_class reg in - let first_reg = Proc.first_available_register.(cl) in - let num_regs = Proc.num_available_registers.(cl) in - let last_reg = first_reg + num_regs in - let score = Array.create num_regs 0 in - let best_score = ref (-1000000) and best_reg = ref (-1) in - let start = start_register.(cl) in - if num_regs > 0 then begin - (* Favor the registers that have been assigned to pseudoregs for which - we have a preference. If these pseudoregs have not been assigned - already, avoid the registers with which they conflict. *) - iter_preferred - (fun r w -> - match r.loc with - Reg n -> if n >= first_reg && n < last_reg then - score.(n - first_reg) <- score.(n - first_reg) + w - | Unknown -> - List.iter - (fun neighbour -> - match neighbour.loc with - Reg n -> if n >= first_reg && n < last_reg then - score.(n - first_reg) <- score.(n - first_reg) - w - | _ -> ()) - r.interf - | _ -> ()) - reg; - List.iter - (fun neighbour -> - (* Prohibit the registers that have been assigned - to our neighbours *) - begin match neighbour.loc with - Reg n -> if n >= first_reg && n < last_reg then - score.(n - first_reg) <- (-1000000) - | _ -> () - end; - (* Avoid the registers that have been assigned to pseudoregs - for which our neighbours have a preference *) - iter_preferred - (fun r w -> - match r.loc with - Reg n -> if n >= first_reg && n < last_reg then - score.(n - first_reg) <- score.(n - first_reg) - (w - 1) - (* w-1 to break the symmetry when two conflicting regs - have the same preference for a third reg. *) - | _ -> ()) - neighbour) - reg.interf; - (* Pick the register with the best score *) - for n = start to num_regs - 1 do - if score.(n) > !best_score then begin - best_score := score.(n); - best_reg := n - end - done; - for n = 0 to start - 1 do - if score.(n) > !best_score then begin - best_score := score.(n); - best_reg := n - end - done - end; - (* Found a register? *) - if !best_reg >= 0 then begin - reg.loc <- Reg(first_reg + !best_reg); - if Proc.rotate_registers then - start_register.(cl) <- (if start+1 >= num_regs then 0 else start+1) - end else begin - (* Sorry, we must put the pseudoreg in a stack location *) - let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in - (* Compute the scores as for registers *) - List.iter - (fun (r, w) -> - match r.loc with - Stack(Local n) -> if Proc.register_class r = cl then - score.(n) <- score.(n) + w - | Unknown -> - List.iter - (fun neighbour -> - match neighbour.loc with - Stack(Local n) -> - if Proc.register_class neighbour = cl - then score.(n) <- score.(n) - w - | _ -> ()) - r.interf - | _ -> ()) - reg.prefer; - List.iter - (fun neighbour -> - begin match neighbour.loc with - Stack(Local n) -> - if Proc.register_class neighbour = cl then - score.(n) <- (-1000000) - | _ -> () - end; - List.iter - (fun (r, w) -> - match r.loc with - Stack(Local n) -> if Proc.register_class r = cl then - score.(n) <- score.(n) - w - | _ -> ()) - neighbour.prefer) - reg.interf; - (* Pick the location with the best score *) - let best_score = ref (-1000000) and best_slot = ref (-1) in - for n = 0 to nslots - 1 do - if score.(n) > !best_score then begin - best_score := score.(n); - best_slot := n + (* Iterate over all registers preferred by the given register (transitive) *) + let iter_preferred f reg = + let rec walk r w = + if not r.visited then begin + f r w; + begin match r.prefer with + [] -> () + | p -> r.visited <- true; + List.iter (fun (r1, w1) -> walk r1 (min w w1)) p; + r.visited <- false + end + end in + reg.visited <- true; + List.iter (fun (r, w) -> walk r w) reg.prefer; + reg.visited <- false in + + (* Where to start the search for a suitable register. + Used to introduce some "randomness" in the choice between registers + with equal scores. This offers more opportunities for scheduling. *) + let start_register = Array.create Proc.num_register_classes 0 in + + (* Assign a location to a register, the best we can. *) + let assign_location reg = + let cl = Proc.register_class reg in + let first_reg = Proc.first_available_register.(cl) in + let num_regs = Proc.num_available_registers.(cl) in + let score = Array.create num_regs 0 in + let best_score = ref (-1000000) and best_reg = ref (-1) in + let start = start_register.(cl) in + if num_regs <> 0 then begin + (* Favor the registers that have been assigned to pseudoregs for which + we have a preference. If these pseudoregs have not been assigned + already, avoid the registers with which they conflict. *) + iter_preferred + (fun r w -> + match r.loc with + Reg n -> let n = n - first_reg in + if n < num_regs then + score.(n) <- score.(n) + w + | Unknown -> + List.iter + (fun neighbour -> + match neighbour.loc with + Reg n -> let n = n - first_reg in + if n < num_regs then + score.(n) <- score.(n) - w + | _ -> ()) + r.interf + | _ -> ()) + reg; + List.iter + (fun neighbour -> + (* Prohibit the registers that have been assigned + to our neighbours *) + begin match neighbour.loc with + Reg n -> let n = n - first_reg in + if n < num_regs then + score.(n) <- (-1000000) + | _ -> () + end; + (* Avoid the registers that have been assigned to pseudoregs + for which our neighbours have a preference *) + iter_preferred + (fun r w -> + match r.loc with + Reg n -> let n = n - first_reg in + if n < num_regs then + score.(n) <- score.(n) - (w-1) + (* w-1 to break the symmetry when two conflicting regs + have the same preference for a third reg. *) + | _ -> ()) + neighbour) + reg.interf; + (* Pick the register with the best score *) + for n = start to num_regs - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_reg := n + end + done; + for n = 0 to start - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_reg := n + end + done + end; + (* Found a register? *) + if !best_reg >= 0 then begin + reg.loc <- Reg(first_reg + !best_reg); + if Proc.rotate_registers then + start_register.(cl) <- (let start = start + 1 in + if start >= num_regs then 0 else start) + end else begin + (* Sorry, we must put the pseudoreg in a stack location *) + let nslots = Proc.num_stack_slots.(cl) in + let score = Array.create nslots 0 in + (* Compute the scores as for registers *) + List.iter + (fun (r, w) -> + match r.loc with + Stack(Local n) -> score.(n) <- score.(n) + w + | Unknown -> + List.iter + (fun neighbour -> + match neighbour.loc with + Stack(Local n) -> score.(n) <- score.(n) - w + | _ -> ()) + r.interf + | _ -> ()) + reg.prefer; + List.iter + (fun neighbour -> + begin match neighbour.loc with + Stack(Local n) -> score.(n) <- (-1000000) + | _ -> () + end; + List.iter + (fun (r, w) -> + match r.loc with + Stack(Local n) -> score.(n) <- score.(n) - w + | _ -> ()) + neighbour.prefer) + reg.interf; + (* Pick the location with the best score *) + let best_score = ref (-1000000) and best_slot = ref (-1) in + for n = 0 to nslots - 1 do + if score.(n) > !best_score then begin + best_score := score.(n); + best_slot := n + end + done; + (* Found one? *) + if !best_slot >= 0 then + reg.loc <- Stack(Local !best_slot) + else begin + (* Allocate a new stack slot *) + reg.loc <- Stack(Local nslots); + Proc.num_stack_slots.(cl) <- nslots + 1 end - done; - (* Found one? *) - if !best_slot >= 0 then - reg.loc <- Stack(Local !best_slot) - else begin - (* Allocate a new stack slot *) - reg.loc <- Stack(Local nslots); - Proc.num_stack_slots.(cl) <- nslots + 1 - end - end; - (* Cancel the preferences of this register so that they don't influence - transitively the allocation of registers that prefer this reg. *) - reg.prefer <- [] + end; + (* Cancel the preferences of this register so that they don't influence + transitively the allocation of registers that prefer this reg. *) + reg.prefer <- [] in -let allocate_registers() = - (* First pass: preallocate spill registers - Second pass: compute the degrees - Third pass: determine coloring order by successive removals of regs - Fourth pass: assign registers in that order *) + (* Reset the stack slot counts *) for i = 0 to Proc.num_register_classes - 1 do Proc.num_stack_slots.(i) <- 0; - start_register.(i) <- 0 done; - List.iter allocate_spilled (Reg.all_registers()); - List.iter find_degree (Reg.all_registers()); - List.iter assign_location (remove_all_regs []) + + (* First pass: preallocate spill registers and split remaining regs + Second pass: assign locations to constrained regs + Third pass: assign locations to unconstrained regs *) + List.iter remove_reg (Reg.all_registers()); + OrderedRegSet.iter assign_location !constrained; + List.iter assign_location !unconstrained diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli index 7b23aa88..b0cd0437 100644 --- a/asmcomp/coloring.mli +++ b/asmcomp/coloring.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: coloring.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Register allocation by coloring of the interference graph *) val allocate_registers: unit -> unit diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 7dc42fd6..6192f1e8 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: comballoc.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Combine heap allocations occurring in the same basic block *) open Mach diff --git a/asmcomp/comballoc.mli b/asmcomp/comballoc.mli index 52f1d115..ee04c16b 100644 --- a/asmcomp/comballoc.mli +++ b/asmcomp/comballoc.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: comballoc.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Combine heap allocations occurring in the same basic block *) val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 9a0bb416..17870c93 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: compilenv.ml 12202 2012-03-07 17:50:17Z frisch $ *) - (* Compilation environments for compilation units *) open Config @@ -22,14 +20,15 @@ open Cmx_format type error = Not_a_unit_info of string | Corrupted_unit_info of string - | Illegal_renaming of string * string + | Illegal_renaming of string * string * string exception Error of error let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) -let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list) +let structured_constants = + ref ([] : (string * bool * Lambda.structured_constant) list) let current_unit = { ui_name = ""; @@ -115,7 +114,7 @@ let read_library_info filename = let cmx_not_found_crc = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" -let get_global_info global_ident = +let get_global_info global_ident = ( let modname = Ident.name global_ident in if modname = current_unit.ui_name then Some current_unit @@ -129,7 +128,7 @@ let get_global_info global_ident = find_in_path_uncap !load_path (modname ^ ".cmx") in let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then - raise(Error(Illegal_renaming(ui.ui_name, filename))); + raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); (Some ui, crc) with Not_found -> (None, cmx_not_found_crc) in @@ -138,6 +137,7 @@ let get_global_info global_ident = Hashtbl.add global_infos_table modname infos; infos end +) let cache_unit_info ui = Hashtbl.add global_infos_table ui.ui_name (Some ui) @@ -232,6 +232,7 @@ let report_error ppf = function | Corrupted_unit_info filename -> fprintf ppf "Corrupted compilation unit description@ %a" Location.print_filename filename - | Illegal_renaming(modname, filename) -> - fprintf ppf "%a@ contains the description for unit@ %s" - Location.print_filename filename modname + | Illegal_renaming(name, modname, filename) -> + fprintf ppf "%a@ contains the description for unit\ + @ %s when %s was expected" + Location.print_filename filename name modname diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 3ff997e4..51cb8c64 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: compilenv.mli 12210 2012-03-08 19:52:03Z doligez $ *) - (* Compilation environments for compilation units *) -open Clambda open Cmx_format val reset: ?packname:string -> string -> unit @@ -54,7 +51,8 @@ val need_send_fun: int -> unit val new_const_symbol : unit -> string val new_const_label : unit -> int val new_structured_constant : Lambda.structured_constant -> bool -> string -val structured_constants : unit -> (string * bool * Lambda.structured_constant) list +val structured_constants : + unit -> (string * bool * Lambda.structured_constant) list val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) @@ -76,7 +74,7 @@ val read_library_info: string -> library_infos type error = Not_a_unit_info of string | Corrupted_unit_info of string - | Illegal_renaming of string * string + | Illegal_renaming of string * string * string exception Error of error diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli index adc5f3e9..ab9442ef 100644 --- a/asmcomp/emit.mli +++ b/asmcomp/emit.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: emit.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Generation of assembly code *) val fundecl: Linearize.fundecl -> unit diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index f45fc162..3ad467cb 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -10,14 +10,9 @@ (* *) (***********************************************************************) -(* $Id: emitaux.ml 12800 2012-07-30 18:59:07Z doligez $ *) - (* Common functions for emitting assembly code *) open Debuginfo -open Cmm -open Reg -open Linearize let output_channel = ref stdout @@ -136,14 +131,12 @@ type emit_frame_actions = let emit_frames a = let filenames = Hashtbl.create 7 in - let lbl_filenames = ref 200000 in let label_filename name = try Hashtbl.find filenames name with Not_found -> - let lbl = !lbl_filenames in + let lbl = Linearize.new_label () in Hashtbl.add filenames name lbl; - incr lbl_filenames; lbl in let emit_frame fd = a.efa_label fd.fd_lbl; @@ -227,7 +220,8 @@ let reset_debug_info () = display .loc for every instruction. *) let emit_debug_info dbg = if is_cfi_enabled () && - !Clflags.debug && not (Debuginfo.is_none dbg) then begin + (!Clflags.debug || Config.with_frame_pointers) + && not (Debuginfo.is_none dbg) then begin let line = dbg.Debuginfo.dinfo_line in assert (line <> 0); (* clang errors out on zero line numbers *) let file_name = dbg.Debuginfo.dinfo_file in diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 4a1934e2..cc479d8c 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: emitaux.mli 12448 2012-05-12 09:49:40Z xleroy $ *) - (* Common functions for emitting assembly code *) val output_channel: out_channel ref diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index f5e21e54..d2f9fd61 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *) - (* Machine-specific command-line options *) let fast_math = ref false @@ -22,7 +20,6 @@ let command_line_options = (* Specific operations for the Intel 386 processor *) -open Misc open Format type addressing_mode = @@ -59,6 +56,8 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +let allow_unaligned_access = true + (* Behavior of division *) let division_crashes_on_overflow = true diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index ace363b5..ec8ec5d8 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,13 +10,11 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *) - (* Emission of Intel 386 assembly code *) -module StringSet = Set.Make(struct type t = string let compare = compare end) +module StringSet = + Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Location open Misc open Cmm open Arch @@ -412,6 +410,23 @@ let emit_floatspecial = function | "tan" -> ` fptan; fstp %st(0)\n` | _ -> assert false +(* Floating-point constants *) + +let float_constants = ref ([] : (string * int) list) + +let add_float_constant cst = + try + List.assoc cst !float_constants + with + Not_found -> + let lbl = new_label() in + float_constants := (cst, lbl) :: !float_constants; + lbl + +let emit_float_constant (cst, lbl) = + `{emit_label lbl}:`; + emit_float64_split_directive ".long" cst + (* Output the assembly code for an instruction *) (* Name of current function *) @@ -420,8 +435,6 @@ let function_name = ref "" let tailrec_entry_point = ref 0 (* Label of trap for out-of-range accesses *) let range_check_trap = ref 0 -(* Record float literals to be emitted later *) -let float_constants = ref ([] : (int * string) list) (* Record references to external C functions (for MacOSX) *) let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty @@ -463,8 +476,7 @@ let emit_instr fallthrough i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + let lbl = add_float_constant s in ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -839,13 +851,6 @@ let rec emit_all fallthrough i = (Linearize.has_fallthrough i.desc) i.next -(* Emission of the floating-point constants *) - -let emit_float_constant (lbl, cst) = - ` .data\n`; - `{emit_label lbl}:`; - emit_float64_split_directive ".long" cst - (* Emission of external symbol references (for MacOSX) *) let emit_external_symbol_direct s = @@ -911,7 +916,6 @@ let fundecl fundecl = fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; - float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; @@ -943,8 +947,7 @@ let fundecl fundecl = "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () end; - List.iter emit_float_constant !float_constants + | _ -> () end (* Emission of data *) @@ -989,6 +992,7 @@ let data l = let begin_assembly() = reset_debug_info(); (* PR#5603 *) + float_constants := []; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; @@ -1000,6 +1004,10 @@ let begin_assembly() = if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = + if !float_constants <> [] then begin + ` .data\n`; + List.iter emit_float_constant !float_constants + end; let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index db4e7b40..b233f818 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,12 +10,10 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp 12800 2012-07-30 18:59:07Z doligez $ *) - (* Emission of Intel 386 assembly code, MASM syntax. *) module StringSet = - Set.Make(struct type t = string let compare = compare end) + Set.Make(struct type t = string let compare (x:t) y = compare x y end) open Misc open Cmm @@ -361,6 +359,39 @@ let emit_floatspecial = function | "tan" -> ` fptan\n\tfstp st(0)\n` | _ -> assert false +(* Floating-point constants *) + +let float_constants = ref ([] : (string * int) list) + +let add_float_constant cst = + try + List.assoc cst !float_constants + with + Not_found -> + let lbl = new_label() in + float_constants := (cst, lbl) :: !float_constants; + lbl + +let emit_float s = + (* MASM doesn't like floating-point constants such as 2e9. + Turn them into 2.0e9. *) + let pos_e = ref (-1) and pos_dot = ref (-1) in + for i = 0 to String.length s - 1 do + match s.[i] with + 'e'|'E' -> pos_e := i + | '.' -> pos_dot := i + | _ -> () + done; + if !pos_dot < 0 && !pos_e >= 0 then begin + emit_string (String.sub s 0 !pos_e); + emit_string ".0"; + emit_string (String.sub s !pos_e (String.length s - !pos_e)) + end else + emit_string s + +let emit_float_constant (cst, lbl) = + `{emit_label lbl} REAL8 {emit_float cst}\n` + (* Output the assembly code for an instruction *) (* Name of current function *) @@ -370,8 +401,6 @@ let tailrec_entry_point = ref 0 (* Label of trap for out-of-range accesses *) let range_check_trap = ref 0 -let float_constants = ref ([] : (int * string) list) - let emit_instr i = match i.desc with Lend -> () @@ -408,8 +437,7 @@ let emit_instr i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + let lbl = add_float_constant s in ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -754,28 +782,6 @@ let emit_instr i = let rec emit_all i = match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next -(* Emission of the floating-point constants *) - -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - -let emit_float_constant (lbl, cst) = - `{emit_label lbl} REAL8 {emit_float cst}\n` - (* Emission of a function declaration *) let fundecl fundecl = @@ -783,7 +789,6 @@ let fundecl fundecl = fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; - float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; @@ -798,14 +803,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - emit_call_bound_errors (); - begin match !float_constants with - [] -> () - | _ -> - ` .DATA\n`; - List.iter emit_float_constant !float_constants; - float_constants := [] - end + emit_call_bound_errors () (* Emission of data *) @@ -848,6 +846,7 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + float_constants := []; `.386\n`; ` .MODEL FLAT\n\n`; ` EXTERN _caml_young_ptr: DWORD\n`; @@ -874,6 +873,10 @@ let begin_assembly() = `{emit_symbol lbl_begin} LABEL DWORD\n` let end_assembly() = + if !float_constants <> [] then begin + ` .DATA\n`; + List.iter emit_float_constant !float_constants; + end; ` .CODE\n`; let lbl_end = Compilenv.make_symbol (Some "code_end") in add_def_symbol lbl_end; diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index c35172c5..e946f699 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: proc.ml 11319 2011-12-16 17:02:48Z xleroy $ *) - (* Description of the Intel 386 processor *) open Misc @@ -201,5 +199,4 @@ let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) -open Clflags;; -open Config;; +let init () = () diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 041c114d..623d12a8 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Cmm open Arch open Reg diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml index a2c21d3f..b166a05a 100644 --- a/asmcomp/i386/scheduling.ml +++ b/asmcomp/i386/scheduling.ml @@ -10,9 +10,7 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *) - -open Schedgen (* to create a dependency *) +let () = let module M = Schedgen in () (* to create a dependency *) (* Scheduling is turned off because our model does not fit the 486 nor the Pentium very well. In particular, it messes up with the diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 8770c57c..cdf7fdfc 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -10,15 +10,12 @@ (* *) (***********************************************************************) -(* $Id: selection.ml 12123 2012-02-04 10:00:44Z bmeurer $ *) - (* Instruction selection for the Intel x86 *) open Misc open Arch open Proc open Cmm -open Reg open Mach (* Auxiliary for recognizing addressing modes *) @@ -133,7 +130,7 @@ let pseudoregs_for_operation op arg res = the result is always left at the top of the floating-point stack *) | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iload((Single | Double | Double_u), _) - | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _, _) | Ifloatspecial _) -> + | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem _ | Ifloatspecial _) -> (arg, [| tos |], false) (* don't move it immediately *) (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) @@ -223,11 +220,13 @@ method! select_operation op args = | Caddf -> self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args | Csubf -> - self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args + self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev + args | Cmulf -> self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args | Cdivf -> - self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args + self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev + args (* Recognize store instructions *) | Cstore Word -> begin match args with diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 4359a802..77acb78a 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -10,15 +10,18 @@ (* *) (***********************************************************************) -(* $Id: interf.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) module IntPairSet = - Set.Make(struct type t = int * int let compare = compare end) + Set.Make(struct + type t = int * int + let compare ((a1,b1) : t) (a2,b2) = + match compare a1 a2 with + | 0 -> compare b1 b2 + | c -> c + end) -open Misc open Reg open Mach @@ -32,13 +35,21 @@ let build_graph fundecl = (* Record an interference between two registers *) let add_interf ri rj = - let i = ri.stamp and j = rj.stamp in - if i <> j then begin - let p = if i < j then (i, j) else (j, i) in - if not(IntPairSet.mem p !mat) then begin - mat := IntPairSet.add p !mat; - if ri.loc = Unknown then ri.interf <- rj :: ri.interf; - if rj.loc = Unknown then rj.interf <- ri :: rj.interf + if Proc.register_class ri = Proc.register_class rj then begin + let i = ri.stamp and j = rj.stamp in + if i <> j then begin + let p = if i < j then (i, j) else (j, i) in + if not(IntPairSet.mem p !mat) then begin + mat := IntPairSet.add p !mat; + if ri.loc = Unknown then begin + ri.interf <- rj :: ri.interf; + if not rj.spill then ri.degree <- ri.degree + 1 + end; + if rj.loc = Unknown then begin + rj.interf <- ri :: rj.interf; + if not ri.spill then rj.degree <- rj.degree + 1 + end + end end end in diff --git a/asmcomp/interf.mli b/asmcomp/interf.mli index e400d53b..a9b0b630 100644 --- a/asmcomp/interf.mli +++ b/asmcomp/interf.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: interf.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 6b918ffd..963ffe9a 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: linearize.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Transformation of Mach code into a list of pseudo-instructions. *) open Reg diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 05866ef3..ad5dc3a9 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: linearize.mli 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Transformation of Mach code into a list of pseudo-instructions. *) type label = int diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index eeaff442..b3085b6c 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: liveness.ml 12058 2012-01-20 14:23:34Z frisch $ *) - (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli index 622fcb48..b52ec5a2 100644 --- a/asmcomp/liveness.mli +++ b/asmcomp/liveness.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: liveness.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index ad81f01c..3e7160b5 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: mach.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Representation of machine code by sequences of pseudoinstructions *) type integer_comparison = diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 9c2a0c04..06fe1c33 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: mach.mli 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Representation of machine code by sequences of pseudoinstructions *) type integer_comparison = diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index c940fa34..cbeba916 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12583 2012-06-07 12:19:23Z xleroy $ *) - (* Specific operations for the PowerPC processor *) -open Misc open Format (* Machine-specific command-line options *) @@ -46,6 +43,8 @@ let size_addr = if ppc64 then 8 else 4 let size_int = size_addr let size_float = 8 +let allow_unaligned_access = false + (* Behavior of division *) let division_crashes_on_overflow = true diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 55ad9830..283312e7 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -10,13 +10,11 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *) - (* Emission of PowerPC assembly code *) -module StringSet = Set.Make(struct type t = string let compare = compare end) +module StringSet = + Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Location open Misc open Cmm open Arch @@ -58,7 +56,7 @@ let supports_backtraces = let emit_symbol = match Config.system with - | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) + | "elf" | "bsd" | "bsd_elf" -> (fun s -> Emitaux.emit_symbol '.' s) | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) | _ -> assert false @@ -66,7 +64,7 @@ let emit_symbol = let label_prefix = match Config.system with - | "elf" | "bsd" -> ".L" + | "elf" | "bsd" | "bsd_elf" -> ".L" | "rhapsody" -> "L" | _ -> assert false @@ -80,19 +78,19 @@ let emit_data_label lbl = let data_space = match Config.system with - | "elf" | "bsd" -> " .section \".data\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".data\"\n" | "rhapsody" -> " .data\n" | _ -> assert false let code_space = match Config.system with - | "elf" | "bsd" -> " .section \".text\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".text\"\n" | "rhapsody" -> " .text\n" | _ -> assert false let rodata_space = match Config.system with - | "elf" | "bsd" -> " .section \".rodata\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".rodata\"\n" | "rhapsody" -> " .const\n" | _ -> assert false @@ -160,7 +158,7 @@ let is_native_immediate n = let emit_upper emit_fun arg = match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> emit_fun arg; emit_string "@ha" | "rhapsody" -> emit_string "ha16("; emit_fun arg; emit_string ")" @@ -168,7 +166,7 @@ let emit_upper emit_fun arg = let emit_lower emit_fun arg = match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> emit_fun arg; emit_string "@l" | "rhapsody" -> emit_string "lo16("; emit_fun arg; emit_string ")" @@ -821,7 +819,7 @@ let rec emit_all i = match i with {desc = Lend} -> () | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} - when is_simple_instr i & no_interference i.res i.next.arg -> + when is_simple_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> @@ -846,7 +844,7 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; begin match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> ` .type {emit_symbol fundecl.fun_name}, @function\n` | _ -> () end; @@ -891,8 +889,11 @@ let fundecl fundecl = let declare_global_data s = ` .globl {emit_symbol s}\n`; - if Config.system = "elf" || Config.system = "bsd" then + match Config.system with + | "elf" | "bsd" | "bsd_elf" -> ` .type {emit_symbol s}, @object\n` + | "rhapsody" -> () + | _ -> assert false let emit_item = function Cglobal_symbol s -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 011f6ff8..203e8a9e 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: proc.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Description of the Power PC *) open Misc @@ -188,7 +186,7 @@ let poweropen_external_conventions first_int last_int let loc_external_arguments = match Config.system with | "rhapsody" -> poweropen_external_conventions 0 7 100 112 - | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8 + | "elf" | "bsd" | "bsd_elf" -> calling_conventions 0 7 100 107 outgoing 8 | _ -> assert false let extcall_use_push = false @@ -237,5 +235,4 @@ let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) -open Clflags;; -open Config;; +let init () = () diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml index 7cc288d7..98f747a8 100644 --- a/asmcomp/power/reload.ml +++ b/asmcomp/power/reload.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Reloading for the PowerPC *) let fundecl f = diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 41817611..e4a575e0 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Instruction scheduling for the Power PC *) open Arch diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index c39bf53c..a68c63fc 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -10,13 +10,9 @@ (* *) (***********************************************************************) -(* $Id: selection.ml 12120 2012-02-04 09:43:33Z bmeurer $ *) - (* Instruction selection for the Power PC processor *) -open Misc open Cmm -open Reg open Arch open Mach diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index 3d89f502..a5081fc4 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -14,7 +14,6 @@ open Format open Asttypes open Clambda -open Debuginfo let rec pr_idents ppf = function | [] -> () @@ -72,16 +71,16 @@ let rec lam ppf = function let switch ppf sw = let spc = ref false in for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) - and l = sw.us_actions_consts.(i) in + let n = sw.us_index_consts.(i) in + let l = sw.us_actions_consts.(n) in if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l; + fprintf ppf "@[case int %i:@ %a@]" i lam l; done; for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) - and l = sw.us_actions_blocks.(i) in + let n = sw.us_index_blocks.(i) in + let l = sw.us_actions_blocks.(n) in if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l; + fprintf ppf "@[case tag %i:@ %a@]" i lam l; done in fprintf ppf "@[<1>(switch %a@ @[%a@])@]" @@ -121,7 +120,9 @@ let rec lam ppf = function let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let kind = - if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in + if k = Lambda.Self then "self" + else if k = Lambda.Cached then "cache" + else "" in fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs and sequence ppf ulam = match ulam with @@ -129,4 +130,5 @@ and sequence ppf ulam = match ulam with fprintf ppf "%a@ %a" sequence l1 sequence l2 | _ -> lam ppf ulam -let clambda = lam +let clambda ppf ulam = + fprintf ppf "%a@." lam ulam diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 99af9d52..f29bcbc4 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printcmm.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Pretty-printing of C-- code *) open Format diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli index 36bc1384..1c97c4a0 100644 --- a/asmcomp/printcmm.mli +++ b/asmcomp/printcmm.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printcmm.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pretty-printing of C-- code *) open Format diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index e617177c..6e177070 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printlinear.ml 12610 2012-06-17 08:15:25Z xleroy $ *) - (* Pretty-printing of linearized machine code *) open Format diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli index df6b7983..68eda9c1 100644 --- a/asmcomp/printlinear.mli +++ b/asmcomp/printlinear.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printlinear.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pretty-printing of linearized machine code *) open Format diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 5f648158..6407f4f7 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printmach.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Pretty-printing of pseudo machine code *) open Format diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli index 3ce05093..bfb0dbef 100644 --- a/asmcomp/printmach.mli +++ b/asmcomp/printmach.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printmach.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pretty-printing of pseudo machine code *) open Format diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 7a27c53b..6cc6aedc 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: proc.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Processor descriptions *) (* Instruction selection *) @@ -48,3 +46,6 @@ val contains_calls: bool ref (* Calling the assembler *) val assemble_file: string -> string -> int + +(* Called before translating a fundecl. *) +val init : unit -> unit diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 6c990b64..1ec0bf9e 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reg.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Cmm type t = diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index a7c4b00e..889e026f 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reg.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pseudo-registers *) type t = diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli index 4462ccd6..cecacbd4 100644 --- a/asmcomp/reload.mli +++ b/asmcomp/reload.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Insert load/stores for pseudoregs that got assigned to stack locations. *) val fundecl: Mach.fundecl -> Mach.fundecl * bool diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 6cf83f63..8f40ad01 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reloadgen.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Insert load/stores for pseudoregs that got assigned to stack locations. *) open Misc diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli index a98a02bf..45c68d1c 100644 --- a/asmcomp/reloadgen.mli +++ b/asmcomp/reloadgen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reloadgen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - class reload_generic : object method reload_operation : Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index c81b2c55..885c9454 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: schedgen.ml 12876 2012-08-24 08:14:30Z xleroy $ *) - (* Instruction scheduling *) -open Misc open Reg open Mach open Linearize diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli index 661451e2..6019d96f 100644 --- a/asmcomp/schedgen.mli +++ b/asmcomp/schedgen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: schedgen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Instruction scheduling *) type code_dag_node = diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli index 5475d011..5949661d 100644 --- a/asmcomp/scheduling.mli +++ b/asmcomp/scheduling.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: scheduling.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Instruction scheduling *) val fundecl: Linearize.fundecl -> Linearize.fundecl diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 797cec57..1d2bf96d 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: selectgen.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 3d81f2ae..11af7c1f 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: selectgen.mli 12120 2012-02-04 09:43:33Z bmeurer $ *) - (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli index 9e20b228..f1c9e34c 100644 --- a/asmcomp/selection.mli +++ b/asmcomp/selection.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: selection.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index f0dbd0d1..f5c06936 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *) - (* Specific operations for the Sparc processor *) -open Misc open Format (* SPARC V8 adds multiply and divide. @@ -47,6 +44,8 @@ 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 diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 4d891b5c..b8387cd7 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12800 2012-07-30 18:59:07Z doligez $ *) - (* Emission of Sparc assembly code *) -open Location open Misc open Cmm open Arch diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 4493354d..ed107a82 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: proc.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Description of the Sparc processor *) open Misc @@ -213,3 +211,5 @@ let assemble_file infile outfile = 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 index 19089783..caae16d7 100644 --- a/asmcomp/sparc/reload.ml +++ b/asmcomp/sparc/reload.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: reload.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Reloading for the Sparc *) let fundecl f = diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index e89a5203..048880ab 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: scheduling.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Cmm open Mach diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 9de2b22d..055b78f1 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -10,11 +10,8 @@ (* *) (***********************************************************************) -(* $Id: selection.ml 12120 2012-02-04 09:43:33Z bmeurer $ *) - (* Instruction selection for the Sparc processor *) -open Misc open Cmm open Reg open Arch diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 82f57a1b..f52b09fc 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: spill.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli index 731c88d9..66954aef 100644 --- a/asmcomp/spill.mli +++ b/asmcomp/spill.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: spill.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 3abeab67..96e9e376 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: split.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - (* Renaming of registers at reload points to split live ranges. *) open Reg @@ -21,7 +19,7 @@ open Mach type subst = Reg.t Reg.Map.t -let subst_reg r sub = +let subst_reg r (sub : subst) = try Reg.Map.find r sub with Not_found -> diff --git a/asmcomp/split.mli b/asmcomp/split.mli index a87f313e..f794fec1 100644 --- a/asmcomp/split.mli +++ b/asmcomp/split.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: split.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmrun/.depend b/asmrun/.depend index 1bbfddcd..c8e6f5c7 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -175,7 +175,7 @@ natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ ../byterun/fail.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ @@ -223,10 +223,11 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/printexc.h stack.h ../byterun/sys.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/int64_native.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -425,7 +426,7 @@ natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ ../byterun/fail.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ @@ -473,10 +474,11 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/printexc.h stack.h ../byterun/sys.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/int64_native.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -675,7 +677,7 @@ natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ ../byterun/fail.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ @@ -723,10 +725,11 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h + ../byterun/printexc.h stack.h ../byterun/sys.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/int64_native.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ diff --git a/asmrun/Makefile b/asmrun/Makefile index d4f0c56e..5ebf7aad 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile 12477 2012-05-24 16:17:19Z xleroy $ - include ../config/Makefile CC=$(NATIVECC) @@ -83,6 +81,9 @@ install-prof: cp libasmrunp.a $(LIBDIR)/libasmrunp.a cd $(LIBDIR); $(RANLIB) libasmrunp.a +power-bsd_elf.S: power-elf.S + cp power-elf.S power-bsd_elf.S + power.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.o @@ -172,8 +173,11 @@ clean:: .SUFFIXES: .S .d.o .p.o .S.o: - $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.S || \ - { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; } + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S || \ + { echo "If your assembler produced syntax errors, it is probably";\ + echo "unhappy with the preprocessor. Check your assembler, or";\ + echo "try producing $*.o by hand.";\ + exit 2; } .S.p.o: $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 79a85d82..876fe602 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -11,14 +11,13 @@ # # ######################################################################### -# $Id: Makefile.nt 12495 2012-05-29 10:41:01Z lefessan $ - include ../config/Makefile CC=$(NATIVECC) -CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS) +CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) \ + $(NATIVECCCOMPOPTS) -COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) \ +COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\ misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ @@ -52,10 +51,10 @@ amd64nt.obj: amd64nt.asm $(ASM)amd64nt.obj amd64nt.asm i386.o: i386.S - $(CC) -c -DSYS_$(SYSTEM) i386.S + $(ASPP) -DSYS_$(SYSTEM) i386.S amd64.o: amd64.S - $(CC) -c -DSYS_$(SYSTEM) amd64.S + $(ASPP) -DSYS_$(SYSTEM) amd64.S install: cp libasmrun.$(A) $(LIBDIR) diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 3ed88abb..aed5a964 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S 12907 2012-09-08 16:51:03Z xleroy $ */ - /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -75,6 +73,23 @@ #define CFI_ADJUST(n) #endif +#ifdef WITH_FRAME_POINTERS + +#define ENTER_FUNCTION \ + pushq %rbp; CFI_ADJUST(8); \ + movq %rsp, %rbp +#define LEAVE_FUNCTION \ + popq %rbp; CFI_ADJUST(-8); + +#else + +#define ENTER_FUNCTION \ + subq $8, %rsp; CFI_ADJUST (8); +#define LEAVE_FUNCTION \ + addq $8, %rsp; CFI_ADJUST (-8); + +#endif + #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -102,21 +117,25 @@ /* Push global [label] on stack. Clobbers %r11. */ #define PUSH_VAR(srclabel) \ movq GREL(srclabel)(%rip), %r11 ; \ - pushq (%r11) + pushq (%r11); CFI_ADJUST (8) /* Pop global [label] off stack. Clobbers %r11. */ #define POP_VAR(dstlabel) \ movq GREL(dstlabel)(%rip), %r11 ; \ - popq (%r11) + popq (%r11); CFI_ADJUST (-8) /* Record lowest stack address and return address. Clobbers %rax. */ #define RECORD_STACK_FRAME(OFFSET) \ - pushq %r11 ; \ + pushq %r11 ; CFI_ADJUST(8); \ movq 8+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_last_return_address) ; \ leaq 16+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_bottom_of_stack) ; \ - popq %r11 + popq %r11; CFI_ADJUST(-8) + +/* Load address of global [label] in register [dst]. */ +#define LEA_VAR(label,dst) \ + movq GREL(label)(%rip), dst #else @@ -135,10 +154,10 @@ testl imm, G(label)(%rip) #define PUSH_VAR(srclabel) \ - pushq G(srclabel)(%rip) + pushq G(srclabel)(%rip) ; CFI_ADJUST(8) #define POP_VAR(dstlabel) \ - popq G(dstlabel)(%rip) + popq G(dstlabel)(%rip); CFI_ADJUST(-8) #define RECORD_STACK_FRAME(OFFSET) \ movq OFFSET(%rsp), %rax ; \ @@ -146,6 +165,8 @@ leaq 8+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_bottom_of_stack) +#define LEA_VAR(label,dst) \ + leaq G(label)(%rip), dst #endif /* Save and restore all callee-save registers on stack. @@ -156,15 +177,15 @@ /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ #define PUSH_CALLEE_SAVE_REGS \ - pushq %rbx; \ - pushq %rbp; \ - pushq %rsi; \ - pushq %rdi; \ - pushq %r12; \ - pushq %r13; \ - pushq %r14; \ - pushq %r15; \ - subq $(8+10*16), %rsp; \ + pushq %rbx; CFI_ADJUST (8); \ + pushq %rbp; CFI_ADJUST (8); \ + pushq %rsi; CFI_ADJUST (8); \ + pushq %rdi; CFI_ADJUST (8); \ + pushq %r12; CFI_ADJUST (8); \ + pushq %r13; CFI_ADJUST (8); \ + pushq %r14; CFI_ADJUST (8); \ + pushq %r15; CFI_ADJUST (8); \ + subq $(8+10*16), %rsp; CFI_ADJUST (8+10*16); \ movupd %xmm6, 0*16(%rsp); \ movupd %xmm7, 1*16(%rsp); \ movupd %xmm8, 2*16(%rsp); \ @@ -187,44 +208,44 @@ movupd 7*16(%rsp), %xmm13; \ movupd 8*16(%rsp), %xmm14; \ movupd 9*16(%rsp), %xmm15; \ - addq $(8+10*16), %rsp; \ - popq %r15; \ - popq %r14; \ - popq %r13; \ - popq %r12; \ - popq %rdi; \ - popq %rsi; \ - popq %rbp; \ - popq %rbx + addq $(8+10*16), %rsp; CFI_ADJUST (-8-10*16); \ + popq %r15; CFI_ADJUST(-8); \ + popq %r14; CFI_ADJUST(-8); \ + popq %r13; CFI_ADJUST(-8); \ + popq %r12; CFI_ADJUST(-8); \ + popq %rdi; CFI_ADJUST(-8); \ + popq %rsi; CFI_ADJUST(-8); \ + popq %rbp; CFI_ADJUST(-8); \ + popq %rbx; CFI_ADJUST(-8) #else /* Unix API: callee-save regs are rbx, rbp, r12-r15 */ #define PUSH_CALLEE_SAVE_REGS \ - pushq %rbx; \ - pushq %rbp; \ - pushq %r12; \ - pushq %r13; \ - pushq %r14; \ - pushq %r15; \ - subq $8, %rsp + pushq %rbx; CFI_ADJUST(8); \ + pushq %rbp; CFI_ADJUST(8); \ + pushq %r12; CFI_ADJUST(8); \ + pushq %r13; CFI_ADJUST(8); \ + pushq %r14; CFI_ADJUST(8); \ + pushq %r15; CFI_ADJUST(8); \ + subq $8, %rsp; CFI_ADJUST(8) #define POP_CALLEE_SAVE_REGS \ - addq $8, %rsp; \ - popq %r15; \ - popq %r14; \ - popq %r13; \ - popq %r12; \ - popq %rbp; \ - popq %rbx + addq $8, %rsp; CFI_ADJUST(-8); \ + popq %r15; CFI_ADJUST(-8); \ + popq %r14; CFI_ADJUST(-8); \ + popq %r13; CFI_ADJUST(-8); \ + popq %r12; CFI_ADJUST(-8); \ + popq %rbp; CFI_ADJUST(-8); \ + popq %rbx; CFI_ADJUST(-8); #endif #ifdef SYS_mingw64 /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ -# define PREPARE_FOR_C_CALL subq $32, %rsp -# define CLEANUP_AFTER_C_CALL addq $32, %rsp +# define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) +# define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) #else # define PREPARE_FOR_C_CALL # define CLEANUP_AFTER_C_CALL @@ -234,6 +255,8 @@ .globl G(caml_system__code_begin) G(caml_system__code_begin): + ret /* just one instruction, so that debuggers don't display + caml_system__code_begin instead of caml_call_gc */ /* Allocation */ @@ -249,26 +272,29 @@ LBL(caml_call_gc): addq $32768, %rsp #endif /* Build array of registers, save it into caml_gc_regs */ - pushq %r11 - pushq %r10 - pushq %rbp - pushq %r13 - pushq %r12 - pushq %r9 - pushq %r8 - pushq %rcx - pushq %rdx - pushq %rsi - pushq %rdi - pushq %rbx - pushq %rax +#ifdef WITH_FRAME_POINTERS + ENTER_FUNCTION ; +#else + pushq %rbp; CFI_ADJUST(8); +#endif + pushq %r11; CFI_ADJUST (8); + pushq %r10; CFI_ADJUST (8); + pushq %r13; CFI_ADJUST (8); + pushq %r12; CFI_ADJUST (8); + pushq %r9; CFI_ADJUST (8); + pushq %r8; CFI_ADJUST (8); + pushq %rcx; CFI_ADJUST (8); + pushq %rdx; CFI_ADJUST (8); + pushq %rsi; CFI_ADJUST (8); + pushq %rdi; CFI_ADJUST (8); + pushq %rbx; CFI_ADJUST (8); + pushq %rax; CFI_ADJUST (8); STORE_VAR(%rsp, caml_gc_regs) /* Save caml_young_ptr, caml_exception_pointer */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) /* Save floating-point registers */ - subq $(16*8), %rsp - CFI_ADJUST(232) + subq $(16*8), %rsp; CFI_ADJUST (16*8); movsd %xmm0, 0*8(%rsp) movsd %xmm1, 1*8(%rsp) movsd %xmm2, 2*8(%rsp) @@ -309,26 +335,30 @@ LBL(caml_call_gc): movsd 13*8(%rsp), %xmm13 movsd 14*8(%rsp), %xmm14 movsd 15*8(%rsp), %xmm15 - addq $(16*8), %rsp - popq %rax - popq %rbx - popq %rdi - popq %rsi - popq %rdx - popq %rcx - popq %r8 - popq %r9 - popq %r12 - popq %r13 - popq %rbp - popq %r10 - popq %r11 - CFI_ADJUST(-232) + addq $(16*8), %rsp; CFI_ADJUST(-16*8) + popq %rax; CFI_ADJUST(-8) + popq %rbx; CFI_ADJUST(-8) + popq %rdi; CFI_ADJUST(-8) + popq %rsi; CFI_ADJUST(-8) + popq %rdx; CFI_ADJUST(-8) + popq %rcx; CFI_ADJUST(-8) + popq %r8; CFI_ADJUST(-8) + popq %r9; CFI_ADJUST(-8) + popq %r12; CFI_ADJUST(-8) + popq %r13; CFI_ADJUST(-8) + popq %r10; CFI_ADJUST(-8) + popq %r11; CFI_ADJUST(-8) +#ifdef WITH_FRAME_POINTERS + LEAVE_FUNCTION +#else + popq %rbp; CFI_ADJUST(-8); +#endif /* Return to caller */ ret - CFI_ENDPROC +CFI_ENDPROC FUNCTION(G(caml_alloc1)) +CFI_STARTPROC LBL(caml_alloc1): subq $16, %r15 CMP_VAR(caml_young_limit, %r15) @@ -336,12 +366,16 @@ LBL(caml_alloc1): ret LBL(100): RECORD_STACK_FRAME(0) - subq $8, %rsp + ENTER_FUNCTION +/* subq $8, %rsp; CFI_ADJUST (8); */ call LBL(caml_call_gc) - addq $8, %rsp +/* addq $8, %rsp; CFI_ADJUST (-8); */ + LEAVE_FUNCTION jmp LBL(caml_alloc1) +CFI_ENDPROC FUNCTION(G(caml_alloc2)) +CFI_STARTPROC LBL(caml_alloc2): subq $24, %r15 CMP_VAR(caml_young_limit, %r15) @@ -349,12 +383,16 @@ LBL(caml_alloc2): ret LBL(101): RECORD_STACK_FRAME(0) - subq $8, %rsp + ENTER_FUNCTION +/* subq $8, %rsp; CFI_ADJUST (8); */ call LBL(caml_call_gc) - addq $8, %rsp +/* addq $8, %rsp; CFI_ADJUST (-8); */ + LEAVE_FUNCTION jmp LBL(caml_alloc2) +CFI_ENDPROC FUNCTION(G(caml_alloc3)) +CFI_STARTPROC LBL(caml_alloc3): subq $32, %r15 CMP_VAR(caml_young_limit, %r15) @@ -362,34 +400,47 @@ LBL(caml_alloc3): ret LBL(102): RECORD_STACK_FRAME(0) - subq $8, %rsp + ENTER_FUNCTION +/* subq $8, %rsp; CFI_ADJUST (8) */ call LBL(caml_call_gc) - addq $8, %rsp +/* addq $8, %rsp; CFI_ADJUST (-8) */ + LEAVE_FUNCTION jmp LBL(caml_alloc3) +CFI_ENDPROC FUNCTION(G(caml_allocN)) +CFI_STARTPROC LBL(caml_allocN): - pushq %rax /* save desired size */ + pushq %rax; CFI_ADJUST(8) /* save desired size */ subq %rax, %r15 CMP_VAR(caml_young_limit, %r15) jb LBL(103) - addq $8, %rsp /* drop desired size */ + addq $8, %rsp; CFI_ADJUST (-8) /* drop desired size */ ret LBL(103): RECORD_STACK_FRAME(8) +#ifdef WITH_FRAME_POINTERS + /* Do we need 16-byte alignment here ? */ + ENTER_FUNCTION +#endif call LBL(caml_call_gc) - popq %rax /* recover desired size */ +#ifdef WITH_FRAME_POINTERS + LEAVE_FUNCTION +#endif + popq %rax; CFI_ADJUST(-8) /* recover desired size */ jmp LBL(caml_allocN) +CFI_ENDPROC /* Call a C function from OCaml */ FUNCTION(G(caml_c_call)) +CFI_STARTPROC LBL(caml_c_call): /* Record lowest stack address and return address */ - popq %r12 + popq %r12; CFI_ADJUST(-8) STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) - pushq %r12 + subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ #ifndef SYS_mingw64 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ @@ -404,39 +455,38 @@ LBL(caml_c_call): /* No need to PREPARE_FOR_C_CALL since the caller already reserved the stack space if needed (cf. amd64/proc.ml) */ jmp *%rax +CFI_ENDPROC /* Start the OCaml program */ FUNCTION(G(caml_start_program)) - CFI_STARTPROC + CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS - CFI_ADJUST(56) /* Initial entry point is G(caml_program) */ leaq GCALL(caml_program)(%rip), %r12 /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ - subq $8, %rsp /* stack 16-aligned */ + subq $8, %rsp; CFI_ADJUST (8) /* stack 16-aligned */ PUSH_VAR(caml_gc_regs) PUSH_VAR(caml_last_return_address) PUSH_VAR(caml_bottom_of_stack) - CFI_ADJUST(32) /* Setup alloc ptr and exception ptr */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) /* Build an exception handler */ lea LBL(108)(%rip), %r13 - pushq %r13 - pushq %r14 + pushq %r13; CFI_ADJUST(8) + pushq %r14; CFI_ADJUST(8) CFI_ADJUST(16) movq %rsp, %r14 /* Call the OCaml code */ call *%r12 LBL(107): /* Pop the exception handler */ - popq %r14 - popq %r12 /* dummy register */ + popq %r14; CFI_ADJUST(-8) + popq %r12; CFI_ADJUST(-8) /* dummy register */ CFI_ADJUST(-16) LBL(109): /* Update alloc ptr and exception ptr */ @@ -446,7 +496,7 @@ LBL(109): POP_VAR(caml_bottom_of_stack) POP_VAR(caml_last_return_address) POP_VAR(caml_gc_regs) - addq $8, %rsp + addq $8, %rsp; CFI_ADJUST (-8); /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ @@ -456,7 +506,7 @@ LBL(108): /* Mark the bucket as an exception result and return it */ orq $2, %rax jmp LBL(109) - CFI_ENDPROC +CFI_ENDPROC /* Registers holding arguments of C functions. */ @@ -475,6 +525,7 @@ LBL(108): /* Raise an exception from OCaml */ FUNCTION(G(caml_raise_exn)) +CFI_STARTPROC TESTL_VAR($1, caml_backtrace_active) jne LBL(110) movq %r14, %rsp @@ -483,45 +534,73 @@ FUNCTION(G(caml_raise_exn)) LBL(110): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ +#ifdef WITH_FRAME_POINTERS + ENTER_FUNCTION + movq 8(%rsp), C_ARG_2 /* arg 2: pc of raise */ + leaq 16(%rsp), C_ARG_3 /* arg 3: sp at raise */ +#else popq C_ARG_2 /* arg 2: pc of raise */ movq %rsp, C_ARG_3 /* arg 3: sp at raise */ +#endif movq %r14, C_ARG_4 /* arg 4: sp of handler */ - /* PR#5700: thanks to popq above, stack is now 16-aligned */ + /* PR#5700: thanks to popq above, stack is now 16-aligned */ + /* Thanks to ENTER_FUNCTION, stack is now 16-aligned */ PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ movq %r14, %rsp popq %r14 ret +CFI_ENDPROC /* Raise an exception from C */ FUNCTION(G(caml_raise_exception)) +CFI_STARTPROC TESTL_VAR($1, caml_backtrace_active) jne LBL(111) movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ - popq %r14 /* Recover previous exception handler */ + popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret LBL(111): +#ifdef WITH_FRAME_POINTERS + ENTER_FUNCTION ; +#endif movq C_ARG_1, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */ LOAD_VAR(caml_bottom_of_stack,C_ARG_3) /* arg 3: sp of raise */ LOAD_VAR(caml_exception_pointer,C_ARG_4) /* arg 4: sp of handler */ +#ifndef WITH_FRAME_POINTERS subq $8, %rsp /* PR#5700: maintain stack alignment */ +#endif PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ LOAD_VAR(caml_exception_pointer,%rsp) popq %r14 /* Recover previous exception handler */ - LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ + LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ ret +CFI_ENDPROC + +/* Raise a Stack_overflow exception on return from segv_handler() + (in asmrun/signals_asm.c). On entry, the stack is full, so we + cannot record a backtrace. + No CFI information here since this function disrupts the stack + backtrace anyway. */ + +FUNCTION(G(caml_stack_overflow)) + LEA_VAR(caml_bucket_Stack_overflow, %rax) + movq %r14, %rsp /* cut the stack */ + popq %r14 /* recover previous exn handler */ + ret /* jump to handler's code */ /* Callback from C to OCaml */ FUNCTION(G(caml_callback_exn)) +CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ @@ -529,8 +608,10 @@ FUNCTION(G(caml_callback_exn)) movq C_ARG_2, %rax /* argument */ movq 0(%rbx), %r12 /* code pointer */ jmp LBL(caml_start_program) +CFI_ENDPROC FUNCTION(G(caml_callback2_exn)) +CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ @@ -539,8 +620,10 @@ FUNCTION(G(caml_callback2_exn)) movq C_ARG_3, %rbx /* second argument */ leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ jmp LBL(caml_start_program) +CFI_ENDPROC FUNCTION(G(caml_callback3_exn)) +CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ @@ -550,10 +633,13 @@ FUNCTION(G(caml_callback3_exn)) movq C_ARG_4, %rdi /* third argument */ leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ jmp LBL(caml_start_program) +CFI_ENDPROC FUNCTION(G(caml_ml_array_bound_error)) +CFI_STARTPROC leaq GCALL(caml_array_bound_error)(%rip), %rax jmp LBL(caml_c_call) +CFI_ENDPROC .globl G(caml_system__code_end) G(caml_system__code_end): diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index 59697150..e86ee72c 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -11,8 +11,6 @@ ;* * ;*********************************************************************** -; $Id: amd64nt.asm 12907 2012-09-08 16:51:03Z xleroy $ - ; Asm part of the runtime system, AMD64 processor, Intel syntax ; Notes on Win64 calling conventions: @@ -51,9 +49,9 @@ L105: mov caml_young_ptr, r15 mov caml_exception_pointer, r14 ; Build array of registers, save it into caml_gc_regs + push rbp push r11 push r10 - push rbp push r13 push r12 push r9 @@ -115,9 +113,9 @@ L105: pop r9 pop r12 pop r13 - pop rbp pop r10 pop r11 + pop rbp ; Restore caml_young_ptr, caml_exception_pointer mov r15, caml_young_ptr mov r14, caml_exception_pointer diff --git a/asmrun/arm.S b/asmrun/arm.S index cb390e45..2ce244a1 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -12,14 +12,22 @@ /* */ /***********************************************************************/ -/* $Id: arm.S 12800 2012-07-30 18:59:07Z doligez $ */ - /* Asm part of the runtime system, ARM processor */ /* Must be preprocessed by cpp */ .syntax unified .text -#if defined(SYS_linux_eabihf) +#if defined(SYS_linux_eabihf) && defined(MODEL_armv6) + .arch armv6 + .fpu vfpv2 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm +#elif defined(SYS_linux_eabihf) .arch armv7-a .fpu vfpv3-d16 .thumb @@ -36,22 +44,30 @@ cmp \reg, #0 beq \lbl .endm - .macro vpop regs - .endm - .macro vpush regs - .endm #endif trap_ptr .req r8 alloc_ptr .req r10 alloc_limit .req r11 +/* Support for CFI directives */ + +#if defined(ASM_CFI_SUPPORTED) +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + /* Support for profiling with gprof */ #if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi)) #define PROFILE \ - push {lr}; \ - bl __gnu_mcount_nc + push {lr}; CFI_ADJUST(4); \ + bl __gnu_mcount_nc; CFI_ADJUST(-4) #else #define PROFILE #endif @@ -63,8 +79,8 @@ caml_system__code_begin: .align 2 .globl caml_call_gc - .type caml_call_gc, %function caml_call_gc: + CFI_STARTPROC PROFILE /* Record return address */ ldr r12, =caml_last_return_address @@ -73,10 +89,12 @@ caml_call_gc: /* Record lowest stack address */ ldr r12, =caml_bottom_of_stack str sp, [r12] +#if defined(SYS_linux_eabihf) /* Save caller floating-point registers on the stack */ - vpush {d0-d7} + vpush {d0-d7}; CFI_ADJUST(64) +#endif /* Save integer registers and return address on the stack */ - push {r0-r7,r12,lr} + push {r0-r7,r12,lr}; CFI_ADJUST(40) /* Store pointer to saved integer registers in caml_gc_regs */ ldr r12, =caml_gc_regs str sp, [r12] @@ -89,9 +107,11 @@ caml_call_gc: /* Call the garbage collector */ bl caml_garbage_collection /* Restore integer registers and return address from the stack */ - pop {r0-r7,r12,lr} + pop {r0-r7,r12,lr}; CFI_ADJUST(-40) +#if defined(SYS_linux_eabihf) /* Restore floating-point registers from the stack */ - vpop {d0-d7} + vpop {d0-d7}; CFI_ADJUST(-64) +#endif /* Reload new allocation pointer and limit */ /* alloc_limit still points to caml_young_ptr */ ldr r12, =caml_young_limit @@ -99,13 +119,14 @@ caml_call_gc: ldr alloc_limit, [r12] /* Return to caller */ bx lr + CFI_ENDPROC .type caml_call_gc, %function .size caml_call_gc, .-caml_call_gc .align 2 .globl caml_alloc1 - .type caml_alloc1, %function caml_alloc1: + CFI_STARTPROC PROFILE .Lcaml_alloc1: sub alloc_ptr, alloc_ptr, 8 @@ -121,13 +142,14 @@ caml_alloc1: ldr lr, [r7] /* Try again */ b .Lcaml_alloc1 + CFI_ENDPROC .type caml_alloc1, %function .size caml_alloc1, .-caml_alloc1 .align 2 .globl caml_alloc2 - .type caml_alloc2, %function caml_alloc2: + CFI_STARTPROC PROFILE .Lcaml_alloc2: sub alloc_ptr, alloc_ptr, 12 @@ -143,6 +165,7 @@ caml_alloc2: ldr lr, [r7] /* Try again */ b .Lcaml_alloc2 + CFI_ENDPROC .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 @@ -150,6 +173,7 @@ caml_alloc2: .globl caml_alloc3 .type caml_alloc3, %function caml_alloc3: + CFI_STARTPROC PROFILE .Lcaml_alloc3: sub alloc_ptr, alloc_ptr, 16 @@ -165,13 +189,14 @@ caml_alloc3: ldr lr, [r7] /* Try again */ b .Lcaml_alloc3 + CFI_ENDPROC .type caml_alloc3, %function .size caml_alloc3, .-caml_alloc3 .align 2 .globl caml_allocN - .type caml_allocN, %function caml_allocN: + CFI_STARTPROC PROFILE .Lcaml_allocN: sub alloc_ptr, alloc_ptr, r7 @@ -188,6 +213,7 @@ caml_allocN: ldr lr, [r12] /* Try again */ b .Lcaml_allocN + CFI_ENDPROC .type caml_allocN, %function .size caml_allocN, .-caml_allocN @@ -196,8 +222,8 @@ caml_allocN: .align 2 .globl caml_c_call - .type caml_c_call, %function caml_c_call: + CFI_STARTPROC PROFILE /* Record lowest stack address and return address */ ldr r5, =caml_last_return_address @@ -219,6 +245,7 @@ caml_c_call: ldr alloc_limit, [r6] /* Return */ bx r4 + CFI_ENDPROC .type caml_c_call, %function .size caml_c_call, .-caml_c_call @@ -226,8 +253,8 @@ caml_c_call: .align 2 .globl caml_start_program - .type caml_start_program, %function caml_start_program: + CFI_STARTPROC PROFILE ldr r12, =caml_program @@ -236,11 +263,14 @@ caml_start_program: /* Arguments to the OCaml code are in r0...r3 */ .Ljump_to_caml: +#if defined(SYS_linux_eabihf) + /* Save callee-save floating-point registers */ + vpush {d8-d15}; CFI_ADJUST(64) +#endif /* Save return address and callee-save registers */ - vpush {d8-d15} - push {r4-r8,r10,r11,lr} /* 8-byte alignment */ + push {r4-r8,r10,r11,lr}; CFI_ADJUST(32) /* 8-byte alignment */ /* Setup a callback link on the stack */ - sub sp, sp, 4*4 /* 8-byte alignment */ + sub sp, sp, 16; CFI_ADJUST(16) /* 8-byte alignment */ ldr r4, =caml_bottom_of_stack ldr r5, =caml_last_return_address ldr r6, =caml_gc_regs @@ -251,7 +281,7 @@ caml_start_program: str r5, [sp, 4] str r6, [sp, 8] /* Setup a trap frame to catch exceptions escaping the OCaml code */ - sub sp, sp, 2*4 + sub sp, sp, 8; CFI_ADJUST(8) ldr r6, =caml_exception_pointer ldr r5, =.Ltrap_handler ldr r4, [r6] @@ -270,7 +300,7 @@ caml_start_program: ldr r4, =caml_exception_pointer ldr r5, [sp, 0] str r5, [r4] - add sp, sp, 2*4 + add sp, sp, 8; CFI_ADJUST(-8) /* Pop the callback link, restoring the global variables */ .Lreturn_result: ldr r4, =caml_bottom_of_stack @@ -282,14 +312,18 @@ caml_start_program: ldr r4, =caml_gc_regs ldr r5, [sp, 8] str r5, [r4] - add sp, sp, 4*4 + add sp, sp, 16; CFI_ADJUST(-16) /* Update allocation pointer */ ldr r4, =caml_young_ptr str alloc_ptr, [r4] - /* Reload callee-save registers and return */ - pop {r4-r8,r10,r11,lr} - vpop {d8-d15} + /* Reload callee-save registers and return address */ + pop {r4-r8,r10,r11,lr}; CFI_ADJUST(-32) +#if defined(SYS_linux_eabihf) + /* Reload callee-save floating-point registers */ + vpop {d8-d15}; CFI_ADJUST(-64) +#endif bx lr + CFI_ENDPROC .type .Lcaml_retaddr, %function .size .Lcaml_retaddr, .-.Lcaml_retaddr .type caml_start_program, %function @@ -299,6 +333,7 @@ caml_start_program: .align 2 .Ltrap_handler: + CFI_STARTPROC /* Save exception pointer */ ldr r12, =caml_exception_pointer str trap_ptr, [r12] @@ -306,6 +341,7 @@ caml_start_program: orr r0, r0, 2 /* Return it */ b .Lreturn_result + CFI_ENDPROC .type .Ltrap_handler, %function .size .Ltrap_handler, .-.Ltrap_handler @@ -314,6 +350,7 @@ caml_start_program: .align 2 .globl caml_raise_exn caml_raise_exn: + CFI_STARTPROC PROFILE /* Test if backtrace is active */ ldr r1, =caml_backtrace_active @@ -332,6 +369,7 @@ caml_raise_exn: mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ pop {trap_ptr, pc} + CFI_ENDPROC .type caml_raise_exn, %function .size caml_raise_exn, .-caml_raise_exn @@ -339,8 +377,8 @@ caml_raise_exn: .align 2 .globl caml_raise_exception - .type caml_raise_exception, %function caml_raise_exception: + CFI_STARTPROC PROFILE /* Reload trap ptr, alloc ptr and alloc limit */ ldr trap_ptr, =caml_exception_pointer @@ -367,6 +405,7 @@ caml_raise_exception: mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ pop {trap_ptr, pc} + CFI_ENDPROC .type caml_raise_exception, %function .size caml_raise_exception, .-caml_raise_exception @@ -374,8 +413,8 @@ caml_raise_exception: .align 2 .globl caml_callback_exn - .type caml_callback_exn, %function caml_callback_exn: + CFI_STARTPROC PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r12, r0 @@ -383,13 +422,14 @@ caml_callback_exn: mov r1, r12 /* r1 = closure environment */ ldr r12, [r12] /* code pointer */ b .Ljump_to_caml + CFI_ENDPROC .type caml_callback_exn, %function .size caml_callback_exn, .-caml_callback_exn .align 2 .globl caml_callback2_exn - .type caml_callback2_exn, %function caml_callback2_exn: + CFI_STARTPROC PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r12, r0 @@ -398,13 +438,14 @@ caml_callback2_exn: mov r2, r12 /* r2 = closure environment */ ldr r12, =caml_apply2 b .Ljump_to_caml + CFI_ENDPROC .type caml_callback2_exn, %function .size caml_callback2_exn, .-caml_callback2_exn .align 2 .globl caml_callback3_exn - .type caml_callback3_exn, %function caml_callback3_exn: + CFI_STARTPROC PROFILE /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ @@ -415,18 +456,20 @@ caml_callback3_exn: mov r3, r12 /* r3 = closure environment */ ldr r12, =caml_apply3 b .Ljump_to_caml + CFI_ENDPROC .type caml_callback3_exn, %function .size caml_callback3_exn, .-caml_callback3_exn .align 2 .globl caml_ml_array_bound_error - .type caml_ml_array_bound_error, %function caml_ml_array_bound_error: + CFI_STARTPROC PROFILE /* Load address of [caml_array_bound_error] in r7 */ ldr r7, =caml_array_bound_error /* Call that function */ b caml_c_call + CFI_ENDPROC .type caml_ml_array_bound_error, %function .size caml_ml_array_bound_error, .-caml_ml_array_bound_error diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index bb714858..3854967c 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -11,11 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c 12149 2012-02-10 16:15:24Z doligez $ */ - /* Stack backtrace for uncaught exceptions */ #include +#include +#include + #include "alloc.h" #include "backtrace.h" #include "memory.h" @@ -54,56 +55,75 @@ CAMLprim value caml_backtrace_status(value vunit) return Val_bool(caml_backtrace_active); } -/* Store the return addresses contained in the given stack fragment - into the backtrace array */ +/* returns the next frame descriptor (or NULL if none is available), + and updates *pc and *sp to point to the following one. */ -void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp) { frame_descr * d; uintnat h; - if (exn != caml_backtrace_last_exn) { - caml_backtrace_pos = 0; - caml_backtrace_last_exn = exn; - } - if (caml_backtrace_buffer == NULL) { - caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); - if (caml_backtrace_buffer == NULL) return; - } if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); while (1) { - /* Find the descriptor corresponding to the return address */ - h = Hash_retaddr(pc); - while(1) { + h = Hash_retaddr(*pc); + while (1) { d = caml_frame_descriptors[h]; - if (d == 0) return; /* can happen if some code not compiled with -g */ - if (d->retaddr == pc) break; + if (d == 0) return NULL; /* can happen if some code compiled without -g */ + if (d->retaddr == *pc) break; h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ if (d->frame_size != 0xFFFF) { - /* Regular frame, store its descriptor in the backtrace buffer */ - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d; + /* Regular frame, update sp/pc and return the frame descriptor */ #ifndef Stack_grows_upwards - sp += (d->frame_size & 0xFFFC); + *sp += (d->frame_size & 0xFFFC); #else - sp -= (d->frame_size & 0xFFFC); + *sp -= (d->frame_size & 0xFFFC); #endif - pc = Saved_return_address(sp); + *pc = Saved_return_address(*sp); #ifdef Mask_already_scanned - pc = Mask_already_scanned(pc); + *pc = Mask_already_scanned(*pc); #endif + return d; } else { /* Special frame marking the top of a stack chunk for an ML callback. Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(sp); - sp = next_context->bottom_of_stack; - pc = next_context->last_retaddr; + struct caml_context * next_context = Callback_link(*sp); + *sp = next_context->bottom_of_stack; + *pc = next_context->last_retaddr; /* A null sp means no more ML stack chunks; stop here. */ - if (sp == NULL) return; + if (*sp == NULL) return NULL; } + } +} + +/* Stores the return addresses contained in the given stack fragment + into the backtrace array ; this version is performance-sensitive as + it is called at each [raise] in a program compiled with [-g], so we + preserved the global, statically bounded buffer of the old + implementation -- before the more flexible + [caml_get_current_callstack] was implemented. */ + +void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +{ + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + if (caml_backtrace_buffer == NULL) { + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return; + } + + /* iterate on each frame */ + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) return; + /* store its descriptor in the backtrace buffer */ + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) descr; + /* Stop when we reach the current exception handler */ #ifndef Stack_grows_upwards if (sp > trapsp) return; @@ -113,6 +133,67 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) } } +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ + +CAMLprim value caml_get_current_callstack(value max_frames_value) { + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + uintnat pc = caml_last_return_address; + /* note that [caml_bottom_of_stack] always points to the most recent + * frame, independently of the [Stack_grows_upwards] setting */ + char * sp = caml_bottom_of_stack; + char * limitsp = caml_top_of_stack; + + trace_size = 0; + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) break; + if (trace_size >= max_frames) break; + ++trace_size; + +#ifndef Stack_grows_upwards + if (sp > limitsp) break; +#else + if (sp < limitsp) break; +#endif + } + } + + trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); + + /* then collect the trace */ + { + uintnat pc = caml_last_return_address; + char * sp = caml_bottom_of_stack; + intnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + Assert(descr != NULL); + /* The assignment below is safe without [caml_initialize], even + if the trace is large and allocated on the old heap, because + we assign values that are outside the OCaml heap. */ + Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); + Field(trace, trace_pos) = (value) descr; + } + } + + CAMLreturn(trace); +} + /* Extract location information for the given frame descriptor */ struct loc_info { @@ -162,22 +243,41 @@ static void extract_location_info(frame_descr * d, li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); } +/* Print location information -- same behavior as in Printexc + + note that the test for compiler-inserted raises is slightly redundant: + (!li->loc_valid && li->loc_is_raise) + extract_location_info above guarantees that when li->loc_valid is + 0, then li->loc_is_raise is always 1, so the latter test is + useless. We kept it to keep code identical to the byterun/ + implementation. */ + static void print_location(struct loc_info * li, int index) { char * info; /* Ignore compiler-inserted raise */ - if (!li->loc_valid) return; - - if (index == 0) - info = "Raised at"; - else if (li->loc_is_raise) - info = "Re-raised at"; - else - info = "Called from"; - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", - info, li->loc_filename, li->loc_lnum, - li->loc_startchr, li->loc_endchr); + if (!li->loc_valid && li->loc_is_raise) return; + + if (li->loc_is_raise) { + /* Initial raise if index == 0, re-raise otherwise */ + if (index == 0) + info = "Raised at"; + else + info = "Re-raised at"; + } else { + if (index == 0) + info = "Raised by primitive operation at"; + else + info = "Called from"; + } + if (! li->loc_valid) { + fprintf(stderr, "%s unknown location\n", info); + } else { + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); + } } /* Print a backtrace */ @@ -193,18 +293,17 @@ void caml_print_exception_backtrace(void) } } -/* Convert the backtrace to a data structure usable from OCaml */ +/* Convert the raw backtrace to a data structure usable from OCaml */ -CAMLprim value caml_get_exception_backtrace(value unit) -{ - CAMLparam0(); +CAMLprim value caml_convert_raw_backtrace(value backtrace) { + CAMLparam1(backtrace); CAMLlocal4(res, arr, p, fname); int i; struct loc_info li; - arr = caml_alloc(caml_backtrace_pos, 0); - for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + extract_location_info((frame_descr *) Field(backtrace, i), &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); p = caml_alloc_small(5, 0); @@ -222,3 +321,35 @@ CAMLprim value caml_get_exception_backtrace(value unit) res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } + +/* Get a copy of the latest backtrace */ + +CAMLprim value caml_get_exception_raw_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal1(res); + res = caml_alloc(caml_backtrace_pos, Abstract_tag); + if(caml_backtrace_buffer != NULL) + memcpy(&Field(res, 0), caml_backtrace_buffer, + caml_backtrace_pos * sizeof(code_t)); + CAMLreturn(res); +} + +/* the function below is deprecated: we previously returned directly + the OCaml-usable representation, instead of the raw backtrace as an + abstract type, but this has a large performance overhead if you + store a lot of backtraces and print only some of them. + + It is not used by the Printexc library anymore, or anywhere else in + the compiler, but we have kept it in case some user still depends + on it as an external. +*/ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal2(raw,res); + raw = caml_get_exception_raw_backtrace(unit); + res = caml_convert_raw_backtrace(raw); + CAMLreturn(res); +} diff --git a/asmrun/fail.c b/asmrun/fail.c index b84f3498..09a9af96 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: fail.c 12128 2012-02-05 09:56:23Z bmeurer $ */ - /* Raising exceptions from C. */ #include diff --git a/asmrun/i386.S b/asmrun/i386.S index f2765871..306c9a58 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: i386.S 12800 2012-07-30 18:59:07Z doligez $ */ - /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -44,6 +42,11 @@ #define FUNCTION_ALIGN 2 #endif +#define FUNCTION(name) \ + .globl G(name); \ + .align FUNCTION_ALIGN; \ + G(name): + #ifdef ASM_CFI_SUPPORTED #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc @@ -57,25 +60,55 @@ #if defined(PROFILING) #if defined(SYS_linux_elf) || defined(SYS_gnu) #define PROFILE_CAML \ - pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + pushl %eax; CFI_ADJUST(4); \ + pushl %ecx; CFI_ADJUST(4); \ + pushl %edx; CFI_ADJUST(4); \ call mcount; \ - popl %edx; popl %ecx; popl %eax; popl %ebp + popl %edx; CFI_ADJUST(-4); \ + popl %ecx; CFI_ADJUST(-4); \ + popl %eax; CFI_ADJUST(-4); \ + popl %ebp; CFI_ADJUST(-4) #define PROFILE_C \ - pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + call mcount; \ + popl %ebp; CFI_ADJUST(-4) #elif defined(SYS_bsd_elf) #define PROFILE_CAML \ - pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + pushl %eax; CFI_ADJUST(4); \ + pushl %ecx; CFI_ADJUST(4); \ + pushl %edx; CFI_ADJUST(4); \ call .mcount; \ - popl %edx; popl %ecx; popl %eax; popl %ebp + popl %edx; CFI_ADJUST(-4); \ + popl %ecx; CFI_ADJUST(-4); \ + popl %eax; CFI_ADJUST(-4); \ + popl %ebp; CFI_ADJUST(-4) #define PROFILE_C \ - pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + call .mcount; \ + popl %ebp; CFI_ADJUST(-4) #elif defined(SYS_macosx) #define PROFILE_CAML \ - pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + pushl %eax; CFI_ADJUST(4); \ + pushl %ecx; CFI_ADJUST(4); \ + pushl %edx; CFI_ADJUST(4); \ call Lmcount$stub; \ - popl %edx; popl %ecx; popl %eax; popl %ebp + popl %edx; CFI_ADJUST(-4); \ + popl %ecx; CFI_ADJUST(-4); \ + popl %eax; CFI_ADJUST(-4); \ + popl %ebp; CFI_ADJUST(-4) #define PROFILE_C \ - pushl %ebp; movl %esp, %ebp; call Lmcount$stub; popl %ebp + pushl %ebp; CFI_ADJUST(4); \ + movl %esp, %ebp; \ + call Lmcount$stub; \ + popl %ebp; CFI_ADJUST(-4) #endif #else #define PROFILE_CAML @@ -83,8 +116,8 @@ #endif #ifdef SYS_macosx -#define ALIGN_STACK(amount) subl $ amount, %esp -#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp +#define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount) +#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount) #else #define ALIGN_STACK(amount) #define UNDO_ALIGN_STACK(amount) @@ -96,14 +129,7 @@ .globl G(caml_system__code_begin) G(caml_system__code_begin): - .globl G(caml_call_gc) - .globl G(caml_alloc1) - .globl G(caml_alloc2) - .globl G(caml_alloc3) - .globl G(caml_allocN) - - .align FUNCTION_ALIGN -G(caml_call_gc): +FUNCTION(caml_call_gc) CFI_STARTPROC PROFILE_CAML /* Record lowest stack address and return address */ @@ -120,33 +146,31 @@ LBL(105): addl $16384, %esp #endif /* Build array of registers, save it into caml_gc_regs */ - pushl %ebp - pushl %edi - pushl %esi - pushl %edx - pushl %ecx - pushl %ebx - pushl %eax - CFI_ADJUST(28) + pushl %ebp; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edx; CFI_ADJUST(4) + pushl %ecx; CFI_ADJUST(4) + pushl %ebx; CFI_ADJUST(4) + pushl %eax; CFI_ADJUST(4) movl %esp, G(caml_gc_regs) /* MacOSX note: 16-alignment of stack preserved at this point */ /* Call the garbage collector */ call G(caml_garbage_collection) /* Restore all regs used by the code generator */ - popl %eax - popl %ebx - popl %ecx - popl %edx - popl %esi - popl %edi - popl %ebp - CFI_ADJUST(-28) + popl %eax; CFI_ADJUST(-4) + popl %ebx; CFI_ADJUST(-4) + popl %ecx; CFI_ADJUST(-4) + popl %edx; CFI_ADJUST(-4) + popl %esi; CFI_ADJUST(-4) + popl %edi; CFI_ADJUST(-4) + popl %ebp; CFI_ADJUST(-4) /* Return to caller */ ret CFI_ENDPROC - .align FUNCTION_ALIGN -G(caml_alloc1): +FUNCTION(caml_alloc1) + CFI_STARTPROC PROFILE_CAML movl G(caml_young_ptr), %eax subl $8, %eax @@ -163,9 +187,10 @@ LBL(100): call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc1) + CFI_ENDPROC - .align FUNCTION_ALIGN -G(caml_alloc2): +FUNCTION(caml_alloc2) + CFI_STARTPROC PROFILE_CAML movl G(caml_young_ptr), %eax subl $12, %eax @@ -182,9 +207,10 @@ LBL(101): call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc2) + CFI_ENDPROC - .align FUNCTION_ALIGN -G(caml_alloc3): +FUNCTION(caml_alloc3) + CFI_STARTPROC PROFILE_CAML movl G(caml_young_ptr), %eax subl $16, %eax @@ -201,9 +227,10 @@ LBL(102): call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc3) + CFI_ENDPROC - .align FUNCTION_ALIGN -G(caml_allocN): +FUNCTION(caml_allocN) + CFI_STARTPROC PROFILE_CAML subl G(caml_young_ptr), %eax /* eax = size - caml_young_ptr */ negl %eax /* eax = caml_young_ptr - size */ @@ -214,7 +241,7 @@ G(caml_allocN): LBL(103): subl G(caml_young_ptr), %eax /* eax = - size */ negl %eax /* eax = size */ - pushl %eax /* save desired size */ + pushl %eax; CFI_ADJUST(4) /* save desired size */ subl %eax, G(caml_young_ptr) /* must update young_ptr */ movl 4(%esp), %eax movl %eax, G(caml_last_return_address) @@ -223,14 +250,14 @@ LBL(103): ALIGN_STACK(8) call LBL(105) UNDO_ALIGN_STACK(8) - popl %eax /* recover desired size */ + popl %eax; CFI_ADJUST(-4) /* recover desired size */ jmp G(caml_allocN) + CFI_ENDPROC /* Call a C function from OCaml */ - .globl G(caml_c_call) - .align FUNCTION_ALIGN -G(caml_c_call): +FUNCTION(caml_c_call) + CFI_STARTPROC PROFILE_CAML /* Record lowest stack address and return address */ movl (%esp), %edx @@ -246,56 +273,52 @@ G(caml_c_call): #endif /* Call the function (address in %eax) */ jmp *%eax + CFI_ENDPROC /* Start the OCaml program */ - .globl G(caml_start_program) - .align FUNCTION_ALIGN -G(caml_start_program): +FUNCTION(caml_start_program) CFI_STARTPROC PROFILE_C /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp - CFI_ADJUST(16) + pushl %ebx; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %ebp; CFI_ADJUST(4) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi /* Common code for caml_start_program and caml_callback* */ LBL(106): /* Build a callback link */ - pushl G(caml_gc_regs) - pushl G(caml_last_return_address) - pushl G(caml_bottom_of_stack) + pushl G(caml_gc_regs); CFI_ADJUST(4) + pushl G(caml_last_return_address); CFI_ADJUST(4) + pushl G(caml_bottom_of_stack); CFI_ADJUST(4) /* Note: 16-alignment preserved on MacOSX at this point */ /* Build an exception handler */ - pushl $ LBL(108) + pushl $ LBL(108); CFI_ADJUST(4) ALIGN_STACK(8) - pushl G(caml_exception_pointer) - CFI_ADJUST(20) + pushl G(caml_exception_pointer); CFI_ADJUST(4) movl %esp, G(caml_exception_pointer) /* Call the OCaml code */ call *%esi LBL(107): /* Pop the exception handler */ - popl G(caml_exception_pointer) + popl G(caml_exception_pointer); CFI_ADJUST(-4) #ifdef SYS_macosx - addl $12, %esp + addl $12, %esp ; CFI_ADJUST(-12) #else - addl $4, %esp + addl $4, %esp ; CFI_ADJUST(-4) #endif - CFI_ADJUST(-8) LBL(109): /* Pop the callback link, restoring the global variables */ - popl G(caml_bottom_of_stack) - popl G(caml_last_return_address) - popl G(caml_gc_regs) + popl G(caml_bottom_of_stack); CFI_ADJUST(-4) + popl G(caml_last_return_address); CFI_ADJUST(-4) + popl G(caml_gc_regs); CFI_ADJUST(-4) /* Restore callee-save registers. */ - popl %ebp - popl %edi - popl %esi - popl %ebx + popl %ebp; CFI_ADJUST(-4) + popl %edi; CFI_ADJUST(-4) + popl %esi; CFI_ADJUST(-4) + popl %ebx; CFI_ADJUST(-4) /* Return to caller. */ ret LBL(108): @@ -307,13 +330,12 @@ LBL(108): /* Raise an exception from OCaml */ - .globl G(caml_raise_exn) - .align FUNCTION_ALIGN -G(caml_raise_exn): +FUNCTION(caml_raise_exn) + CFI_STARTPROC testl $1, G(caml_backtrace_active) jne LBL(110) movl G(caml_exception_pointer), %esp - popl G(caml_exception_pointer) + popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret LBL(110): @@ -322,86 +344,86 @@ LBL(110): movl 0(%esp), %eax /* PC of raise */ leal 4(%esp), %edx /* SP of raise */ ALIGN_STACK(12) - pushl %edi /* arg 4: sp of handler */ - pushl %edx /* arg 3: sp of raise */ - pushl %eax /* arg 2: pc of raise */ - pushl %esi /* arg 1: exception bucket */ + pushl %edi; CFI_ADJUST(4) /* arg 4: sp of handler */ + pushl %edx; CFI_ADJUST(4) /* arg 3: sp of raise */ + pushl %eax; CFI_ADJUST(4) /* arg 2: pc of raise */ + pushl %esi; CFI_ADJUST(4) /* arg 1: exception bucket */ call G(caml_stash_backtrace) movl %esi, %eax /* Recover exception bucket */ movl %edi, %esp - popl G(caml_exception_pointer) + popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret + CFI_ENDPROC /* Raise an exception from C */ - .globl G(caml_raise_exception) - .align FUNCTION_ALIGN -G(caml_raise_exception): +FUNCTION(caml_raise_exception) + CFI_STARTPROC PROFILE_C testl $1, G(caml_backtrace_active) jne LBL(111) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp - popl G(caml_exception_pointer) + popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret LBL(111): movl 4(%esp), %esi /* Save exception bucket in esi */ ALIGN_STACK(12) - pushl G(caml_exception_pointer) /* arg 4: sp of handler */ - pushl G(caml_bottom_of_stack) /* arg 3: sp of raise */ - pushl G(caml_last_return_address) /* arg 2: pc of raise */ - pushl %esi /* arg 1: exception bucket */ + pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */ + pushl G(caml_bottom_of_stack); CFI_ADJUST(4) /* 3: sp of raise */ + pushl G(caml_last_return_address); CFI_ADJUST(4)/* 2: pc of raise */ + pushl %esi; CFI_ADJUST(4) /* 1: exception bucket */ call G(caml_stash_backtrace) movl %esi, %eax /* Recover exception bucket */ movl G(caml_exception_pointer), %esp - popl G(caml_exception_pointer) + popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret + CFI_ENDPROC /* Callback from C to OCaml */ - .globl G(caml_callback_exn) - .align FUNCTION_ALIGN -G(caml_callback_exn): +FUNCTION(caml_callback_exn) + CFI_STARTPROC PROFILE_C /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp + pushl %ebx; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %ebp; CFI_ADJUST(4) /* Initial loading of arguments */ movl 20(%esp), %ebx /* closure */ movl 24(%esp), %eax /* argument */ movl 0(%ebx), %esi /* code pointer */ jmp LBL(106) + CFI_ENDPROC - .globl G(caml_callback2_exn) - .align FUNCTION_ALIGN -G(caml_callback2_exn): +FUNCTION(caml_callback2_exn) + CFI_STARTPROC PROFILE_C /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp + pushl %ebx; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %ebp; CFI_ADJUST(4) /* Initial loading of arguments */ movl 20(%esp), %ecx /* closure */ movl 24(%esp), %eax /* first argument */ movl 28(%esp), %ebx /* second argument */ movl $ G(caml_apply2), %esi /* code pointer */ jmp LBL(106) + CFI_ENDPROC - .globl G(caml_callback3_exn) - .align FUNCTION_ALIGN -G(caml_callback3_exn): +FUNCTION(caml_callback3_exn) + CFI_STARTPROC PROFILE_C /* Save callee-save registers */ - pushl %ebx - pushl %esi - pushl %edi - pushl %ebp + pushl %ebx; CFI_ADJUST(4) + pushl %esi; CFI_ADJUST(4) + pushl %edi; CFI_ADJUST(4) + pushl %ebp; CFI_ADJUST(4) /* Initial loading of arguments */ movl 20(%esp), %edx /* closure */ movl 24(%esp), %eax /* first argument */ @@ -409,10 +431,10 @@ G(caml_callback3_exn): movl 32(%esp), %ecx /* third argument */ movl $ G(caml_apply3), %esi /* code pointer */ jmp LBL(106) + CFI_ENDPROC - .globl G(caml_ml_array_bound_error) - .align FUNCTION_ALIGN -G(caml_ml_array_bound_error): +FUNCTION(caml_ml_array_bound_error) + CFI_STARTPROC /* Empty the floating-point stack */ ffree %st(0) ffree %st(1) @@ -433,6 +455,7 @@ G(caml_ml_array_bound_error): #endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) + CFI_ENDPROC .globl G(caml_system__code_end) G(caml_system__code_end): diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 6a6098a1..d7449741 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -11,8 +11,6 @@ ;* * ;*********************************************************************** -; $Id: i386nt.asm 12800 2012-07-30 18:59:07Z doligez $ - ; Asm part of the runtime system, Intel 386 processor, Intel syntax .386 diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index 8625c545..edb389db 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -18,7 +18,6 @@ #include "callback.h" #include "alloc.h" #include "intext.h" -#include "natdynlink.h" #include "osdeps.h" #include "fail.h" diff --git a/asmrun/natdynlink.h b/asmrun/natdynlink.h deleted file mode 100644 index e69de29b..00000000 diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index fa182421..94f4a29d 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: power-elf.S 12800 2012-07-30 18:59:07Z doligez $ */ - #define Addrglobal(reg,glob) \ addis reg, 0, glob@ha; \ addi reg, reg, glob@l diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index eab18095..309c955b 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: power-rhapsody.S 12800 2012-07-30 18:59:07Z doligez $ */ - #ifdef __ppc64__ #define X(a,b) b #else diff --git a/asmrun/roots.c b/asmrun/roots.c index 0df8a24d..93e7a655 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: roots.c 12800 2012-07-30 18:59:07Z doligez $ */ - /* To walk the memory roots for garbage collection */ #include "finalise.h" diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 4065826e..4f62bd38 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -11,14 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: signals_asm.c 12159 2012-02-17 10:12:09Z xleroy $ */ - /* Signal handling, code specific to the native-code compiler */ #if defined(TARGET_amd64) && defined (SYS_linux) #define _GNU_SOURCE #endif #include +#include #include #include "fail.h" #include "memory.h" @@ -75,6 +74,9 @@ void caml_garbage_collection(void) DECLARE_SIGNAL_HANDLER(handle_signal) { + int saved_errno; + /* Save the value of errno (PR#5982). */ + saved_errno = errno; #if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) signal(sig, handle_signal); #endif @@ -92,6 +94,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; #endif } + errno = saved_errno; } int caml_set_signal_action(int signo, int action) @@ -187,6 +190,10 @@ static char sig_alt_stack[SIGSTKSZ]; #define EXTRA_STACK 0x2000 #endif +#ifdef RETURN_AFTER_STACK_OVERFLOW +extern void caml_stack_overflow(void); +#endif + DECLARE_SIGNAL_HANDLER(segv_handler) { struct rlimit limit; @@ -206,19 +213,31 @@ DECLARE_SIGNAL_HANDLER(segv_handler) && Is_in_code_area(CONTEXT_PC) #endif ) { - /* Turn this into a Stack_overflow exception */ +#ifdef RETURN_AFTER_STACK_OVERFLOW + /* Tweak the PC part of the context so that on return from this + handler, we jump to the asm function [caml_stack_overflow] + (from $ARCH.S). */ +#ifdef CONTEXT_PC + CONTEXT_PC = (context_reg) &caml_stack_overflow; +#else +#error "CONTEXT_PC must be defined if RETURN_AFTER_STACK_OVERFLOW is" +#endif +#else + /* Raise a Stack_overflow exception straight from this signal handler */ #if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; #endif caml_raise_stack_overflow(); +#endif + } else { + /* Otherwise, deactivate our exception handler and return, + causing fatal signal to be generated at point of error. */ + act.sa_handler = SIG_DFL; + act.sa_flags = 0; + sigemptyset(&act.sa_mask); + sigaction(SIGSEGV, &act, NULL); } - /* Otherwise, deactivate our exception handler and return, - causing fatal signal to be generated at point of error. */ - act.sa_handler = SIG_DFL; - act.sa_flags = 0; - sigemptyset(&act.sa_mask); - sigaction(SIGSEGV, &act, NULL); } #endif diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index f0d1f3bb..ff198475 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: signals_osdep.h 12124 2012-02-04 10:15:24Z bmeurer $ */ - /* Processor- and OS-dependent signal interface */ /****************** AMD64, Linux */ @@ -30,7 +28,7 @@ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP]) #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) - #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.gregs[REG_CR2]) + #define CONTEXT_FAULTING_ADDRESS ((char *)context->uc_mcontext.gregs[REG_CR2]) /****************** AMD64, MacOSX */ @@ -46,12 +44,14 @@ #include #include -#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #if !defined(MAC_OS_X_VERSION_10_5) \ + || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r #endif + typedef unsigned long long context_reg; #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip)) #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14)) @@ -59,11 +59,25 @@ #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) -/****************** ARM, Linux */ + #define RETURN_AFTER_STACK_OVERFLOW -#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf)) +/****************** ARM, Linux */ - #include +#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \ + || defined(SYS_linux_eabihf)) + + #if defined(__ANDROID__) + // The Android NDK does not have sys/ucontext.h yet. + typedef struct ucontext { + uint32_t uc_flags; + struct ucontext *uc_link; + stack_t uc_stack; + struct sigcontext uc_mcontext; + // Other fields omitted... + } ucontext_t; + #else + #include + #endif #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) @@ -137,7 +151,8 @@ #include #include -#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #if !defined(MAC_OS_X_VERSION_10_5) \ + || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r @@ -188,7 +203,8 @@ #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) #endif -#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #if !defined(MAC_OS_X_VERSION_10_5) \ + || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r @@ -221,7 +237,7 @@ /****************** PowerPC, BSD */ -#elif defined(TARGET_power) && defined(SYS_bsd) +#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf)) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, int code, struct sigcontext * context) diff --git a/asmrun/sparc.S b/asmrun/sparc.S index 19cb6d83..7f24b4b4 100644 --- a/asmrun/sparc.S +++ b/asmrun/sparc.S @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: sparc.S 12800 2012-07-30 18:59:07Z doligez $ */ - /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ diff --git a/asmrun/stack.h b/asmrun/stack.h index a801405e..57c87fa9 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: stack.h 12159 2012-02-17 10:12:09Z xleroy $ */ - /* Machine-dependent interface with the asm code */ #ifndef CAML_STACK_H @@ -37,7 +35,8 @@ #ifdef TARGET_power #define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) #define Already_scanned(sp, retaddr) ((retaddr) & 1) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1) +#define Mark_scanned(sp, retaddr) \ + (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1) #define Mask_already_scanned(retaddr) ((retaddr) & ~1) #ifdef SYS_aix #define Trap_frame_size 32 diff --git a/asmrun/startup.c b/asmrun/startup.c index fc7f464c..1ccd4eca 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: startup.c 12227 2012-03-13 14:44:48Z xleroy $ */ - /* Start-up code */ #include @@ -33,7 +31,6 @@ #include "printexc.h" #include "stack.h" #include "sys.h" -#include "natdynlink.h" #ifdef HAS_UI #include "ui.h" #endif @@ -57,7 +54,7 @@ static void init_atoms(void) } if (caml_page_table_add(In_static_data, caml_atom_table, caml_atom_table + 256) != 0) - caml_fatal_error("Fatal error: not enough memory for the initial page table"); + caml_fatal_error("Fatal error: not enough memory for initial page table"); for (i = 0; caml_data_segments[i].begin != 0; i++) { /* PR#5509: we must include the zero word at end of data segment, @@ -65,7 +62,7 @@ static void init_atoms(void) if (caml_page_table_add(In_static_data, caml_data_segments[i].begin, caml_data_segments[i].end + sizeof(value)) != 0) - caml_fatal_error("Fatal error: not enough memory for the initial page table"); + caml_fatal_error("Fatal error: not enough memory for initial page table"); } caml_code_area_start = caml_code_segments[0].begin; @@ -150,6 +147,14 @@ extern value caml_start_program (void); extern void caml_init_ieee_floats (void); extern void caml_init_signals (void); +#ifdef _MSC_VER + +/* PR 4887: avoid crash box of windows runtime on some system calls */ +extern void caml_install_invalid_parameter_handler(); + +#endif + + void caml_main(char **argv) { char * exe_name; @@ -160,6 +165,9 @@ void caml_main(char **argv) char tos; caml_init_ieee_floats(); +#ifdef _MSC_VER + caml_install_invalid_parameter_handler(); +#endif caml_init_custom_operations(); #ifdef DEBUG caml_verb_gc = 63; diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot index cbb279dd..ab7ae092 100755 Binary files a/boot/myocamlbuild.boot and b/boot/myocamlbuild.boot differ diff --git a/boot/ocamlc b/boot/ocamlc index bc99e6c1..72164e97 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 468fff35..cdfd1dc7 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 105cb698..31beb410 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/boot.sh b/build/boot.sh index 3aaf231f..c0d49a28 100755 --- a/build/boot.sh +++ b/build/boot.sh @@ -12,11 +12,14 @@ # # ######################################################################### -# $Id: boot.sh 11156 2011-07-27 14:17:02Z doligez $ cd `dirname $0`/.. set -ex TAG_LINE='true: -use_stdlib' -./boot/ocamlrun boot/myocamlbuild.boot \ + +# If you modify this list, modify it also in camlp4-native-only.sh +STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' + +./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \ -tag-line "$TAG_LINE" \ boot/stdlib.cma boot/std_exit.cmo diff --git a/build/camlp4-bootstrap-recipe.txt b/build/camlp4-bootstrap-recipe.txt index 12060380..3be13199 100644 --- a/build/camlp4-bootstrap-recipe.txt +++ b/build/camlp4-bootstrap-recipe.txt @@ -1,3 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + === Initial setup === make clean ./build/distclean.sh diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index 663cd1e4..cbfe05c7 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: camlp4-byte-only.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh index b39556b2..0ff20e8b 100755 --- a/build/camlp4-mkCamlp4Ast.sh +++ b/build/camlp4-mkCamlp4Ast.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: camlp4-mkCamlp4Ast.sh 11156 2011-07-27 14:17:02Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index b80fbca0..d53395c2 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -12,10 +12,12 @@ # # ######################################################################### -# $Id: camlp4-native-only.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE + +# If you modify this list, modify it also in boot.sh +STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' + +$OCAMLBUILD -ignore "$STDLIB_MODULES" $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh index e20eb5bf..8fbaafb5 100644 --- a/build/camlp4-targets.sh +++ b/build/camlp4-targets.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: camlp4-targets.sh 11156 2011-07-27 14:17:02Z doligez $ CAMLP4_COMMON="\ camlp4/Camlp4/Camlp4Ast.partial.ml \ camlp4/boot/camlp4boot.byte" diff --git a/build/distclean.sh b/build/distclean.sh index fa0a96a1..aa8b2f31 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: distclean.sh 11156 2011-07-27 14:17:02Z doligez $ - cd `dirname $0`/.. set -ex (cd byterun && make clean) || : diff --git a/build/fastworld.sh b/build/fastworld.sh index a91af9c7..0e3302ef 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: fastworld.sh 11156 2011-07-27 14:17:02Z doligez $ - cd `dirname $0` set -e if [ -e ocamlbuild_mixed_mode ]; then diff --git a/build/install.sh b/build/install.sh index df01db42..d092d664 100755 --- a/build/install.sh +++ b/build/install.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: install.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. @@ -553,6 +551,8 @@ installdir \ ocamlbuildlib.cmxa \ ocamlbuildlib.cma \ ocamlbuild_plugin.cmi \ + ocamlbuild_plugin.cmo \ + ocamlbuild_plugin.cmx \ ocamlbuild_pack.cmi \ ocamlbuild_unix_plugin.cmi \ ocamlbuild_unix_plugin.cmo \ diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 86532e66..75d6e9ca 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -12,12 +12,11 @@ # # ######################################################################### -# $Id: mkmyocamlbuild_config.sh 11156 2011-07-27 14:17:02Z doligez $ - cd `dirname $0`/.. sed \ -e 's/^.*FLEXDIR.*$//g' \ + -e '/^SET_LD_PATH/d' \ -e 's/^#ml \(.*\)/\1/' \ -e 's/^\([^"][^"]*\("[^"]*"[^"]*\)*\)#.*$/\1/' \ -e 's/^\(#.*\)$/(* \1 *)/' \ diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh index 46e3e011..a1bf141e 100755 --- a/build/mkruntimedef.sh +++ b/build/mkruntimedef.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: mkruntimedef.sh 11156 2011-07-27 14:17:02Z doligez $ echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ sed -e '$s/;$//'; \ diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh index 05f82101..34ad894f 100755 --- a/build/myocamlbuild.sh +++ b/build/myocamlbuild.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: myocamlbuild.sh 11156 2011-07-27 14:17:02Z doligez $ - cd `dirname $0`/.. set -xe if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then diff --git a/build/new-build-system b/build/new-build-system index 690ea4ad..acd7125d 100644 --- a/build/new-build-system +++ b/build/new-build-system @@ -1,3 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + _tags # Defines tags to setup exceptions myocamlbuild.ml # Contains all needed rules that are differents boot/ocamldep diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index a2eb184a..aeb5bcba 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: ocamlbuild-byte-only.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index fcb384d9..4d7decfc 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: ocamlbuild-native-only.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index de620ff9..285c561a 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: ocamlbuildlib-native-only.sh 11156 2011-07-27 14:17:02Z doligez $ - set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index 0d1b53ab..bd28a0dc 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: otherlibs-targets.sh 11156 2011-07-27 14:17:02Z doligez $ - OTHERLIBS_BYTE="" OTHERLIBS_NATIVE="" OTHERLIBS_UNIX_NATIVE="" diff --git a/build/partial-install.sh b/build/partial-install.sh index a8113c9b..c06154a8 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -12,8 +12,6 @@ # # ######################################################################### -# $Id: partial-install.sh 12113 2012-02-03 12:03:04Z bmeurer $ - ###################################### ######### Copied from build/install.sh ###################################### @@ -168,6 +166,8 @@ installdir \ ocamlbuildlib.cmxa \ ocamlbuildlib.cma \ ocamlbuild_plugin.cmi \ + ocamlbuild_plugin.cmo \ + ocamlbuild_plugin.cmx \ ocamlbuild_pack.cmi \ ocamlbuild_unix_plugin.cmi \ ocamlbuild_unix_plugin.cmo \ diff --git a/build/targets.sh b/build/targets.sh index b4ae57ea..219f73cd 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: targets.sh 11156 2011-07-27 14:17:02Z doligez $ - . config/config.sh . build/otherlibs-targets.sh . build/camlp4-targets.sh diff --git a/build/world.all.sh b/build/world.all.sh index cf14cef1..45c053cd 100755 --- a/build/world.all.sh +++ b/build/world.all.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: world.all.sh 11156 2011-07-27 14:17:02Z doligez $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.byte.sh b/build/world.byte.sh index db2ef7d2..5a520b99 100755 --- a/build/world.byte.sh +++ b/build/world.byte.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: world.byte.sh 11156 2011-07-27 14:17:02Z doligez $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.native.sh b/build/world.native.sh index 7f1aa75b..4f99467b 100755 --- a/build/world.native.sh +++ b/build/world.native.sh @@ -12,7 +12,6 @@ # # ######################################################################### -# $Id: world.native.sh 11156 2011-07-27 14:17:02Z doligez $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 044d3371..e933df53 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytegen.ml 12167 2012-02-18 17:21:42Z xleroy $ *) - (* bytegen.ml : translation of lambda terms to lists of instructions. *) open Misc @@ -332,6 +330,12 @@ let comp_primitive p args = | Pstringsets -> Kccall("caml_string_set", 3) | Pstringrefu -> Kgetstringchar | Pstringsetu -> Ksetstringchar + | Pstring_load_16(_) -> Kccall("caml_string_get16", 2) + | Pstring_load_32(_) -> Kccall("caml_string_get32", 2) + | Pstring_load_64(_) -> Kccall("caml_string_get64", 2) + | Pstring_set_16(_) -> Kccall("caml_string_set16", 3) + | Pstring_set_32(_) -> Kccall("caml_string_set32", 3) + | Pstring_set_64(_) -> Kccall("caml_string_set64", 3) | Parraylength kind -> Kvectlength | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2) @@ -345,6 +349,14 @@ let comp_primitive p args = | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3) | Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3) | Parraysetu _ -> Ksetvectitem + | Pctconst c -> + let const_name = match c with + | Big_endian -> "big_endian" + | Word_size -> "word_size" + | Ostype_unix -> "ostype_unix" + | Ostype_win32 -> "ostype_win32" + | Ostype_cygwin -> "ostype_cygwin" in + Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1) | Pisint -> Kisint | Pisout -> Kisout | Pbittest -> Kccall("caml_bitvect_test", 2) @@ -376,6 +388,15 @@ let comp_primitive p args = | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) + | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1) + | Pbigstring_load_16(_) -> Kccall("caml_ba_uint8_get16", 2) + | Pbigstring_load_32(_) -> Kccall("caml_ba_uint8_get32", 2) + | Pbigstring_load_64(_) -> Kccall("caml_ba_uint8_get64", 2) + | Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3) + | Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3) + | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) + | Pbswap16 -> Kccall("caml_bswap16", 1) + | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index bfa7a7a5..3c24cc8e 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytegen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Generation of bytecode from lambda terms *) open Lambda diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index 35c5e8fb..fdcb0d88 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytelibrarian.ml 12202 2012-03-07 17:50:17Z frisch $ *) - (* Build libraries of .cmo files *) open Misc @@ -38,7 +36,6 @@ let copy_compunit ic oc compunit = (* Add C objects and options and "custom" info from a library descriptor *) -let lib_sharedobjs = ref [] let lib_ccobjs = ref [] let lib_ccopts = ref [] let lib_dllibs = ref [] @@ -94,12 +91,13 @@ let create_archive ppf file_list lib_name = output_string outchan cma_magic_number; let ofs_pos_toc = pos_out outchan in output_binary_int outchan 0; - let units = List.flatten(List.map (copy_object_file ppf outchan) file_list) in + let units = + List.flatten(List.map (copy_object_file ppf outchan) file_list) in let toc = { lib_units = units; lib_custom = !Clflags.custom_runtime; lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs; - lib_ccopts = !Clflags.ccopts @ !lib_ccopts; + 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; diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli index 7f65246d..757874cb 100644 --- a/bytecomp/bytelibrarian.mli +++ b/bytecomp/bytelibrarian.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytelibrarian.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Build libraries of .cmo files *) (* Format of a library file: diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index f40e4253..20983668 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -10,25 +10,22 @@ (* *) (***********************************************************************) -(* $Id: bytelink.ml 12357 2012-04-16 15:27:42Z frisch $ *) - (* Link a set of .cmo files and produce a bytecode executable. *) -open Sys open Misc open Config -open Instruct open Cmo_format type error = File_not_found of string | Not_an_object_file of string + | Wrong_object_name of string | Symbol_error of string * Symtable.error | Inconsistent_import of string * string * string | Custom_runtime | File_exists of string | Cannot_open_dll of string - + | Not_compatible_32 exception Error of error @@ -177,7 +174,9 @@ let check_consistency ppf file_name cu = begin try let source = List.assoc cu.cu_name !implementations_defined in Location.print_warning (Location.in_file file_name) ppf - (Warnings.Multiple_definition(cu.cu_name, Location.show_filename file_name, Location.show_filename source)) + (Warnings.Multiple_definition(cu.cu_name, + Location.show_filename file_name, + Location.show_filename source)) with Not_found -> () end; implementations_defined := @@ -188,21 +187,21 @@ let extract_crc_interfaces () = (* Record compilation events *) -let debug_info = ref ([] : (int * string) list) +let debug_info = ref ([] : (int * LongString.t) list) (* Link in a compilation unit *) let link_compunit ppf output_fun currpos_fun inchan file_name compunit = check_consistency ppf file_name compunit; seek_in inchan compunit.cu_pos; - let code_block = input_bytes inchan compunit.cu_codesize in - Symtable.patch_object code_block compunit.cu_reloc; + let code_block = LongString.input_bytes inchan compunit.cu_codesize in + Symtable.ls_patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = input_bytes inchan compunit.cu_debugsize in + let buffer = LongString.input_bytes inchan compunit.cu_debugsize in debug_info := (currpos_fun(), buffer) :: !debug_info end; - output_fun code_block; + Array.iter output_fun code_block; if !Clflags.link_everything then List.iter Symtable.require_primitive compunit.cu_primitives @@ -255,7 +254,9 @@ let link_file ppf output_fun currpos_fun = function let output_debug_info oc = output_binary_int oc (List.length !debug_info); List.iter - (fun (ofs, evl) -> output_binary_int oc ofs; output_string oc evl) + (fun (ofs, evl) -> + output_binary_int oc ofs; + Array.iter (output_string oc) evl) !debug_info; debug_info := [] @@ -274,6 +275,12 @@ let make_absolute file = (* Create a bytecode executable file *) let link_bytecode ppf tolink exec_name standalone = + (* Avoid the case where the specified exec output file is the same as + one of the objects to be linked *) + List.iter (function + | Link_object(file_name, _) when file_name = exec_name -> + raise (Error (Wrong_object_name exec_name)); + | _ -> ()) tolink; Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *) let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] @@ -330,7 +337,13 @@ let link_bytecode ppf tolink exec_name standalone = Symtable.output_primitive_names outchan; Bytesections.record outchan "PRIM"; (* The table of global data *) - output_value outchan (Symtable.initial_global_table()); + 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; Bytesections.record outchan "DATA"; (* The map of global identifiers *) Symtable.output_global_map outchan; @@ -507,7 +520,8 @@ let link ppf objfiles output_name = else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in let tolink = List.fold_right scan_file objfiles [] in Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *) - Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) + Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; + (* put user's opts first *) Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *) if not !Clflags.custom_runtime then link_bytecode ppf tolink output_name true @@ -583,6 +597,9 @@ let report_error ppf = function | Not_an_object_file name -> fprintf ppf "The file %a is not a bytecode object file" Location.print_filename name + | Wrong_object_name name -> + fprintf ppf "The output file %s has the wrong name. The extension implies\ + \ an object file but the link step was requested" name | Symbol_error(name, err) -> fprintf ppf "Error while linking %a:@ %a" Location.print_filename name Symtable.report_error err @@ -601,3 +618,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" diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index b33dbdfc..6e123c3f 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -10,24 +10,25 @@ (* *) (***********************************************************************) -(* $Id: bytelink.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit -val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit +val check_consistency: + Format.formatter -> string -> Cmo_format.compilation_unit -> unit val extract_crc_interfaces: unit -> (string * Digest.t) list type error = File_not_found of string | Not_an_object_file of string + | Wrong_object_name of string | Symbol_error of string * Symtable.error | Inconsistent_import of string * string * string | Custom_runtime | File_exists of string | Cannot_open_dll of string + | Not_compatible_32 exception Error of error diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 821883a3..f548c771 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytepackager.ml 12800 2012-07-30 18:59:07Z doligez $ *) - (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) @@ -23,7 +21,7 @@ type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t | Not_an_object_file of string - | Illegal_renaming of string * string + | Illegal_renaming of string * string * string | File_not_found of string exception Error of error @@ -93,7 +91,7 @@ type pack_member = pm_name: string; pm_kind: pack_member_kind } -let read_member_info file = +let read_member_info file = ( let name = String.capitalize(Filename.basename(chop_extensions file)) in let kind = @@ -107,7 +105,7 @@ let read_member_info file = seek_in ic compunit_pos; let compunit = (input_value ic : compilation_unit) in if compunit.cu_name <> name - then raise(Error(Illegal_renaming(file, compunit.cu_name))); + then raise(Error(Illegal_renaming(name, file, compunit.cu_name))); close_in ic; PM_impl compunit with x -> @@ -116,6 +114,7 @@ let read_member_info file = end else PM_intf in { pm_file = file; pm_name = name; pm_kind = kind } +) (* Read the bytecode from a .cmo file. Write bytecode to channel [oc]. @@ -123,7 +122,8 @@ let read_member_info file = Accumulate relocs, debug info, etc. Return size of bytecode. *) -let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst objfile compunit = +let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst + objfile compunit = let ic = open_in_bin objfile in try Bytelink.check_consistency ppf objfile compunit; @@ -147,22 +147,27 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst o (* Same, for a list of .cmo and .cmi files. Return total size of bytecode. *) -let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst = function +let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs + prefix subst = + function [] -> ofs | m :: rem -> match m.pm_kind with | PM_intf -> - rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst rem + rename_append_bytecode_list ppf packagename oc mapping defined ofs + prefix subst rem | PM_impl compunit -> let size = - rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst - m.pm_file compunit in + rename_append_bytecode ppf packagename oc mapping defined ofs + prefix subst m.pm_file compunit in let id = Ident.create_persistent m.pm_name in let root = Path.Pident (Ident.create_persistent prefix) in - rename_append_bytecode_list ppf packagename - oc mapping (id :: defined) - (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem + rename_append_bytecode_list ppf packagename oc mapping (id :: defined) + (ofs + size) prefix + (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) + subst) + rem (* Generate the code that builds the tuple representing the package module *) @@ -202,7 +207,8 @@ let package_object_files ppf files targetfile targetname coercion = let pos_depl = pos_out oc in output_binary_int oc 0; let pos_code = pos_out oc in - let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0 targetname Subst.identity members in + let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0 + targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then @@ -264,8 +270,9 @@ let report_error ppf = function | Not_an_object_file file -> fprintf ppf "%a is not a bytecode object file" Location.print_filename file - | Illegal_renaming(file, id) -> - fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" - Location.print_filename file id + | Illegal_renaming(name, file, id) -> + fprintf ppf "Wrong file naming: %a@ contains the code for\ + @ %s when %s was expected" + Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 01d0a6fe..04de0726 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytepackager.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) @@ -21,7 +19,7 @@ type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t | Not_an_object_file of string - | Illegal_renaming of string * string + | Illegal_renaming of string * string * string | File_not_found of string exception Error of error diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 73e8964d..5af3bc52 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytesections.ml 12184 2012-02-23 19:54:44Z doligez $ *) - (* Handling of sections in bytecode executable files *) (* List of all sections, in reverse order *) @@ -52,7 +50,7 @@ let read_toc ic = if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; - for i = 1 to num_sections do + for _i = 1 to num_sections do let name = Misc.input_bytes ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index 0b825d1d..b9639c1f 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: bytesections.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Handling of sections in bytecode executable files *) (** Recording sections written to a bytecode executable file *) diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index f234eaca..abf4f1af 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: cmo_format.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Symbol table information for .cmo and .cma files *) (* Relocation information *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index c765cbef..5c62b9ed 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: dll.ml 12661 2012-07-07 11:41:17Z scherer $ *) - (* Handling of dynamically-linked libraries *) type dll_handle diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 4eaecfde..975315e2 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: dll.mli 12661 2012-07-07 11:41:17Z scherer $ *) - (* Handling of dynamically-linked libraries *) (* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 3be75e34..2f1d5859 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: emitcode.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Generation of bytecode + relocation information *) open Config @@ -24,21 +22,21 @@ open Cmo_format (* Buffering of bytecode *) -let out_buffer = ref(String.create 1024) +let out_buffer = ref(LongString.create 1024) and out_position = ref 0 let out_word b1 b2 b3 b4 = let p = !out_position in - if p >= String.length !out_buffer then begin - let len = String.length !out_buffer in - let new_buffer = String.create (2 * len) in - String.blit !out_buffer 0 new_buffer 0 len; + if p >= LongString.length !out_buffer then begin + let len = LongString.length !out_buffer in + let new_buffer = LongString.create (2 * len) in + LongString.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; - String.unsafe_set !out_buffer p (Char.unsafe_chr b1); - String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); - String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); - String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + LongString.set !out_buffer p (Char.unsafe_chr b1); + LongString.set !out_buffer (p+1) (Char.unsafe_chr b2); + LongString.set !out_buffer (p+2) (Char.unsafe_chr b3); + LongString.set !out_buffer (p+3) (Char.unsafe_chr b4); out_position := p + 4 let out opcode = @@ -88,10 +86,10 @@ let extend_label_table needed = let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in - !out_buffer.[pos] <- Char.unsafe_chr displ; - !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); - !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); - !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + LongString.set !out_buffer pos (Char.unsafe_chr displ); + LongString.set !out_buffer (pos+1) (Char.unsafe_chr (displ asr 8)); + LongString.set !out_buffer (pos+2) (Char.unsafe_chr (displ asr 16)); + LongString.set !out_buffer (pos+3) (Char.unsafe_chr (displ asr 24)) let define_label lbl = if lbl >= Array.length !label_table then extend_label_table lbl; @@ -342,7 +340,8 @@ let rec emit = function (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c -> emit (Kpush :: instr1 :: instr2 :: ev :: c) | Kpush :: (Kevent {ev_kind = Event_before} as ev) :: - (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c -> + (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr):: + c -> emit (Kpush :: instr :: ev :: c) | Kgetglobal id :: Kgetfield n :: c -> out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c @@ -359,7 +358,7 @@ let to_file outchan unit_name code = output_binary_int outchan 0; let pos_code = pos_out outchan in emit code; - output outchan !out_buffer 0 !out_position; + LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin let p = pos_out outchan in @@ -373,7 +372,8 @@ let to_file outchan unit_name code = cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; cu_imports = Env.imported_units(); - cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; + cu_primitives = List.map Primitive.byte_name + !Translmod.primitive_declarations; cu_force_link = false; cu_debug = pos_debug; cu_debugsize = size_debug } in @@ -392,7 +392,7 @@ let to_memory init_code fun_code = emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - String.unsafe_blit !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in init(); @@ -403,7 +403,7 @@ let to_memory init_code fun_code = let to_packed_file outchan code = init(); emit code; - output outchan !out_buffer 0 !out_position; + LongString.output outchan !out_buffer 0 !out_position; let reloc = !reloc_info in init(); reloc diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index fdcca261..60d79143 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: emitcode.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Generation of bytecode for .cmo files *) open Cmo_format diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 3fe1f4fe..5edcacd2 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: instruct.ml 12149 2012-02-10 16:15:24Z doligez $ *) - open Lambda type compilation_env = diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index 3d347369..d81228ac 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: instruct.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* The type of the instructions of the abstract machine *) open Lambda diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index eb586ce9..cfced858 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -10,12 +10,17 @@ (* *) (***********************************************************************) -(* $Id: lambda.ml 12070 2012-01-23 14:49:39Z lefessan $ *) - open Misc open Path open Asttypes +type compile_time_constant = + | Big_endian + | Word_size + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + type primitive = Pidentity | Pignore @@ -86,6 +91,28 @@ type primitive = (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pstring_set_16 of bool + | Pstring_set_32 of bool + | Pstring_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -241,7 +268,7 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args -let rec iter f = function +let iter f = function Lvar _ | Lconst _ -> () | Lapply(fn, args, _) -> diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index c4623b66..17da073c 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -10,12 +10,17 @@ (* *) (***********************************************************************) -(* $Id: lambda.mli 12070 2012-01-23 14:49:39Z lefessan $ *) - (* The "lambda" intermediate code *) open Asttypes +type compile_time_constant = + | Big_endian + | Word_size + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + type primitive = Pidentity | Pignore @@ -86,6 +91,28 @@ type primitive = (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pstring_set_16 of bool + | Pstring_set_32 of bool + | Pstring_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 8dd21aeb..5c1d8726 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: matching.ml 12961 2012-09-27 13:30:07Z garrigue $ *) - (* Compilation of pattern matching *) open Misc @@ -32,12 +30,12 @@ open Printf (* - Many functions on the various data structures ofthe algorithm : + Many functions on the various data structures of the algorithm : - Pattern matrices. - Default environments: mapping from matrices to exit numbers. - Contexts: matrices whose column are partitioned into left and right. - - Jump sumaries: mapping from exit numbers to contexts + - Jump summaries: mapping from exit numbers to contexts *) type matrix = pattern list list @@ -162,9 +160,9 @@ let make_default matcher env = let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (_, _, cstr,omegas,_) -> + | Tpat_construct (_, cstr,omegas,_) -> (fun q rem -> match q.pat_desc with - | Tpat_construct (_, _, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> + | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> p,args @ rem | Tpat_any -> p,omegas @ rem | _ -> raise NoMatch) @@ -201,8 +199,8 @@ let ctx_matcher p = (fun q rem -> match q.pat_desc with | Tpat_record (l',_) -> let l' = all_record_args l' in - p, List.fold_right (fun (_, _, _,p) r -> p::r) l' rem - | _ -> p,List.fold_right (fun (_, _, _,p) r -> p::r) l rem) + p, List.fold_right (fun (_, _,p) r -> p::r) l' rem + | _ -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem) | Tpat_lazy omega -> (fun q rem -> match q.pat_desc with | Tpat_lazy arg -> p, (arg::rem) @@ -274,9 +272,9 @@ let ctx_match ctx pss = pss) ctx -type jumps = (int * ctx ) list +type jumps = (int * ctx list) list -let pretty_jumps env = match env with +let pretty_jumps (env : jumps) = match env with | [] -> () | _ -> List.iter @@ -342,7 +340,7 @@ let rec jumps_unions envs = match envs with | [env] -> env | _ -> jumps_unions (merge envs) -let rec jumps_map f env = +let jumps_map f env = List.map (fun (i,pss) -> i,f pss) env @@ -530,7 +528,7 @@ let simplify_or p = with | Var p -> p -let rec simplify_cases args cls = match args with +let simplify_cases args cls = match args with | [] -> assert false | (arg,_)::_ -> let rec simplify = function @@ -614,9 +612,9 @@ let rec extract_vars r p = match p.pat_desc with List.fold_left extract_vars r pats | Tpat_record (lpats,_) -> List.fold_left - (fun r (_, _, _, p) -> extract_vars r p) + (fun r (_, _, p) -> extract_vars r p) r lpats -| Tpat_construct (_, _, _, pats,_) -> +| Tpat_construct (_, _, pats,_) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -666,7 +664,7 @@ let group_constant = function | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct (_, _, _, _,_)} -> true + | {pat_desc = Tpat_construct _} -> true | _ -> false and group_variant = function @@ -696,7 +694,7 @@ and group_lazy = function let get_group p = match p.pat_desc with | Tpat_any -> group_var | Tpat_constant _ -> group_constant -| Tpat_construct (_, _, _, _, _) -> group_constructor +| Tpat_construct _ -> group_constructor | Tpat_tuple _ -> group_tuple | Tpat_record _ -> group_record | Tpat_array _ -> group_array @@ -1131,15 +1129,15 @@ let make_field_args binding_kind arg first_pos last_pos argl = in make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr.cstr_tag + | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag | _ -> assert false let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, _, args, _)} -> args @ rem +| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem | _ -> assert false let pat_as_constr = function - | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr + | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr | _ -> fatal_error "Matching.pat_as_constr" @@ -1153,7 +1151,7 @@ let matcher_constr cstr = match cstr.cstr_arity with with | NoMatch -> matcher_rec p2 rem end - | Tpat_construct (_, _, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> rem | Tpat_any -> rem | _ -> raise NoMatch in @@ -1174,7 +1172,7 @@ let matcher_constr cstr = match cstr.cstr_arity with rem | _, _ -> assert false end - | Tpat_construct (_, _, cstr1, [arg],_) + | Tpat_construct (_, cstr1, [arg],_) when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem | Tpat_any -> omega::rem | _ -> raise NoMatch in @@ -1182,7 +1180,7 @@ let matcher_constr cstr = match cstr.cstr_arity with | _ -> fun q rem -> match q.pat_desc with | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_, _, cstr1, args,_) + | Tpat_construct (_, cstr1, args,_) when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem | _ -> raise NoMatch @@ -1331,7 +1329,8 @@ let get_mod_field modname field = match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") - with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.") + with Not_found -> + fatal_error ("Primitive "^modname^"."^field^" not found.") in Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])]) with Not_found -> fatal_error ("Module "^modname^" unavailable.") @@ -1381,21 +1380,21 @@ let inline_lazy_force_switch arg loc = (Lswitch (varg, { sw_numconsts = 0; sw_consts = []; - sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1; + sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) sw_blocks = [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); (Obj.lazy_tag, Lapply(force_fun, [varg], loc)) ]; sw_failaction = Some varg } )))) -let inline_lazy_force = +let inline_lazy_force arg loc = if !Clflags.native_code then (* Lswitch generates compact and efficient native code *) - inline_lazy_force_switch + inline_lazy_force_switch arg loc else (* generating bytecode: Lswitch would generate too many rather big tables (~ 250 elts); conditionals are better *) - inline_lazy_force_cond + inline_lazy_force_cond arg loc let make_lazy_matching def = function [] -> fatal_error "Matching.make_lazy_matching" @@ -1448,7 +1447,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = let patv = Array.create num_fields omega in - List.iter (fun (_, _, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv let get_args_record num_fields p rem = match p with @@ -1755,7 +1754,7 @@ let as_interval_canfail fail low high l = (cur_low,i-1,0):: nofail_rec i i index rem in - let rec init_rec = function + let init_rec = function | [] -> [] | (i,act_i)::rem -> let index = store.act_store act_i in @@ -2317,7 +2316,7 @@ let bind_check str v arg lam = match str,arg with | Alias,_ -> lower_bind v arg lam | _,_ -> bind str v arg lam -let rec comp_exit ctx m = match m.default with +let comp_exit ctx m = match m.default with | (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx | _ -> fatal_error "Matching.comp_exit" @@ -2386,6 +2385,7 @@ let arg_to_var arg cls = match arg with Output: a lambda term, a jump summary {..., exit number -> context, .. } *) +let dbg = false let rec compile_match repr partial ctx m = match m with | { cases = [] } -> comp_exit ctx m @@ -2403,13 +2403,14 @@ let rec compile_match repr partial ctx m = match m with { m with args = (newarg, Alias) :: argl } in let (lam, total) = comp_match_handlers - (do_compile_matching repr) partial ctx newarg first_match rem in + ((if dbg then do_compile_matching_pr else do_compile_matching) repr) + partial ctx newarg first_match rem in bind_check str v arg lam, total | _ -> assert false (* verbose version of do_compile_matching, for debug *) -(* + and do_compile_matching_pr repr partial ctx arg x = prerr_string "COMPILE: " ; prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ; @@ -2421,7 +2422,7 @@ and do_compile_matching_pr repr partial ctx arg x = prerr_endline "JUMPS" ; pretty_jumps jumps ; r -*) + and do_compile_matching repr partial ctx arg pmh = match pmh with | Pm pm -> let pat = what_is_cases pm.cases in @@ -2433,7 +2434,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_no_test (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_record ((_, _, lbl,_)::_,_) -> + | Tpat_record ((_, lbl,_)::_,_) -> compile_no_test (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm @@ -2443,7 +2444,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with divide_constant (combine_constant arg cst partial) ctx pm - | Tpat_construct (_, _, cstr, _, _) -> + | Tpat_construct (_, cstr, _, _) -> compile_test (compile_match repr partial) partial divide_constructor (combine_constructor arg pat cstr partial) @@ -2483,21 +2484,86 @@ and compile_no_test divide up_ctx repr partial ctx to_match = (* The entry points *) (* - If there is a guard in a matching, then - set exhaustiveness info to Partial. - (because of side effects in guards, assume the worst) + If there is a guard in a matching or a lazy pattern, + then set exhaustiveness info to Partial. + (because of side effects, assume the worst). + + Notice that exhaustiveness information is trusted by the compiler, + that is, a match flagged as Total should not fail at runtime. + More specifically, for instance if match y with x::_ -> x uis flagged + total (as it happens during JoCaml compilation) then y cannot be [] + at runtime. As a consequence, the static Total exhaustiveness information + have to to be downgraded to Partial, in the dubious cases where guards + 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. + I have generalized teh patch, so as to also find mutable fields. *) -let check_partial pat_act_list partial = - if +let find_in_pat pred = + let rec find_rec p = + pred p.pat_desc || + begin match p.pat_desc with + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> + find_rec p + | Tpat_tuple ps|Tpat_construct (_,_,ps,_) | Tpat_array ps -> + List.exists find_rec ps + | Tpat_record (lpats,_) -> + List.exists + (fun (_, _, p) -> find_rec p) + lpats + | Tpat_or (p,q,_) -> + find_rec p || find_rec q + | Tpat_constant _ | Tpat_var _ + | Tpat_any | Tpat_variant (_,None,_) -> false + end in + find_rec + +let is_lazy_pat = function + | Tpat_lazy _ -> true + | Tpat_alias _ | Tpat_variant _ | Tpat_record _ + | Tpat_tuple _|Tpat_construct _ | Tpat_array _ + | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any + -> false + +let is_lazy p = find_in_pat is_lazy_pat p + +let have_mutable_field p = match p with +| Tpat_record (lps,_) -> List.exists - (fun (_,lam) -> is_guarded lam) - pat_act_list - then begin - Partial - end else - partial + (fun (_,lbl,_) -> + match lbl.Types.lbl_mut with + | Mutable -> true + | Immutable -> false) + lps +| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ +| Tpat_tuple _|Tpat_construct _ | Tpat_array _ +| Tpat_or _ +| Tpat_constant _ | Tpat_var _ | Tpat_any + -> false + +let is_mutable p = find_in_pat have_mutable_field p + +(* Downgrade Total when + 1. Matching accesses some mutable fields; + 2. And there are guards or lazy patterns. +*) +let check_partial is_mutable is_lazy pat_act_list = function + | Partial -> Partial + | Total -> + if + List.exists + (fun (pats, lam) -> + is_mutable pats && (is_guarded lam || is_lazy pats)) + pat_act_list + then Partial + else Total + +let check_partial_list = + check_partial (List.exists is_mutable) (List.exists is_lazy) +let check_partial = check_partial is_mutable is_lazy (* have toplevel handler when appropriate *) @@ -2560,7 +2626,7 @@ let for_let loc param pat body = (* Easy case since variables are available *) let for_tupled_function loc paraml pats_act_list partial = - let partial = check_partial pats_act_list partial in + let partial = check_partial_list pats_act_list partial in let raise_num = next_raise_count () in let omegas = [List.map (fun _ -> omega) paraml] in let pm = @@ -2586,8 +2652,8 @@ let rec flatten_pat_line size p k = match p.pat_desc with | Tpat_any -> omegas size::k | 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 *) +| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a + useless binding, solves PR #3780 *) flatten_pat_line size p k | _ -> fatal_error "Matching.flatten_pat_line" @@ -2615,7 +2681,7 @@ let flatten_pm size args pm = default = flatten_def size pm.default} -let rec flatten_precompiled size args pmh = match pmh with +let flatten_precompiled size args pmh = match pmh with | Pm pm -> Pm (flatten_pm size args pm) | PmOr {body=b ; handlers=hs ; or_matrix=m} -> PmOr @@ -2704,7 +2770,7 @@ let arg_to_var arg cls = match arg with v,Lvar v -let rec param_to_var param = match param with +let param_to_var param = match param with | Lvar v -> v,None | _ -> Ident.create "match",Some param diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 06faf06a..5c8577b2 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: matching.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Compilation of pattern-matching *) open Typedtree diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index b04adaf3..35d87766 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: meta.ml 11156 2011-07-27 14:17:02Z doligez $ *) - external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" external static_alloc : int -> string = "caml_static_alloc" diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index 70425d26..a8ef5272 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: meta.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* To control the runtime system and bytecode interpreter *) external global_data : unit -> Obj.t array = "caml_get_global_data" diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index 842ab784..a5cd7e05 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printinstr.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pretty-print lists of instructions *) open Format diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli index f15985d0..dd4fd15b 100644 --- a/bytecomp/printinstr.mli +++ b/bytecomp/printinstr.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printinstr.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Pretty-print lists of instructions *) open Instruct diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 8c5b784a..65316700 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printlambda.ml 12179 2012-02-21 17:41:02Z xleroy $ *) - open Format open Asttypes open Primitive @@ -156,6 +154,14 @@ let primitive ppf = function | Parraysetu _ -> fprintf ppf "array.unsafe_set" | Parrayrefs _ -> fprintf ppf "array.get" | Parraysets _ -> fprintf ppf "array.set" + | Pctconst c -> + let const_name = match c with + | Big_endian -> "big_endian" + | Word_size -> "word_size" + | Ostype_unix -> "ostype_unix" + | Ostype_win32 -> "ostype_win32" + | Ostype_cygwin -> "ostype_cygwin" in + fprintf ppf "sys.constant_%s" const_name | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" | Pbittest -> fprintf ppf "testbit" @@ -184,6 +190,45 @@ let primitive ppf = function print_bigarray "get" unsafe kind ppf layout | Pbigarrayset(unsafe, n, kind, layout) -> print_bigarray "set" unsafe kind ppf layout + | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n + | Pstring_load_16(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get16" + else fprintf ppf "string.get16" + | Pstring_load_32(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get32" + else fprintf ppf "string.get32" + | Pstring_load_64(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get64" + else fprintf ppf "string.get64" + | Pstring_set_16(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_set16" + else fprintf ppf "string.set16" + | Pstring_set_32(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_set32" + else fprintf ppf "string.set32" + | Pstring_set_64(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_set64" + else fprintf ppf "string.set64" + | Pbigstring_load_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" + else fprintf ppf "bigarray.array1.get16" + | Pbigstring_load_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get32" + else fprintf ppf "bigarray.array1.get32" + | Pbigstring_load_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get64" + else fprintf ppf "bigarray.array1.get64" + | Pbigstring_set_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" + else fprintf ppf "bigarray.array1.set16" + | Pbigstring_set_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" + else fprintf ppf "bigarray.array1.set32" + | Pbigstring_set_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" + else fprintf ppf "bigarray.array1.set64" + | Pbswap16 -> fprintf ppf "bswap16" + | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi let rec lam ppf = function | Lvar id -> diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli index 98c7ed0d..4a546b63 100644 --- a/bytecomp/printlambda.mli +++ b/bytecomp/printlambda.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: printlambda.mli 12179 2012-02-21 17:41:02Z xleroy $ *) - open Lambda open Format diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli index 44116c83..c06038a4 100644 --- a/bytecomp/runtimedef.mli +++ b/bytecomp/runtimedef.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: runtimedef.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Values and functions known and/or provided by the runtime system *) val builtin_exceptions: string array diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index a6e045cd..e60bb6d1 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: simplif.ml 12174 2012-02-20 17:45:10Z xleroy $ *) - (* Elimination of useless Llet(Alias) bindings. Also transform let-bound references into variables. *) @@ -266,7 +264,8 @@ let simplify_exits lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> Lifused (v,simplif l) in @@ -476,7 +475,8 @@ let simplify_lets lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli index a25bfea1..4cc6dab9 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: simplif.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Elimination of useless Llet(Alias) bindings. Transformation of let-bound references into variables. Simplification over staticraise/staticcatch constructs. diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 7ab4bfd9..63374f82 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: symtable.ml 12629 2012-06-21 15:55:03Z doligez $ *) - (* To assign numbers to globals and primitives *) open Misc @@ -177,25 +175,28 @@ let init () = (* Must use the unsafe String.set here because the block may be a "fake" string as returned by Meta.static_alloc. *) -let patch_int buff pos n = - String.unsafe_set buff pos (Char.unsafe_chr n); - String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); - String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); - String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) +let gen_patch_int str_set buff pos n = + str_set buff pos (Char.unsafe_chr n); + str_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); + str_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); + str_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) -let patch_object buff patchlist = +let gen_patch_object str_set buff patchlist = List.iter (function (Reloc_literal sc, pos) -> - patch_int buff pos (slot_for_literal sc) + gen_patch_int str_set buff pos (slot_for_literal sc) | (Reloc_getglobal id, pos) -> - patch_int buff pos (slot_for_getglobal id) + gen_patch_int str_set buff pos (slot_for_getglobal id) | (Reloc_setglobal id, pos) -> - patch_int buff pos (slot_for_setglobal id) + gen_patch_int str_set buff pos (slot_for_setglobal id) | (Reloc_primitive name, pos) -> - patch_int buff pos (num_of_prim name)) + gen_patch_int str_set buff pos (num_of_prim name)) patchlist +let patch_object = gen_patch_object String.unsafe_set +let ls_patch_object = gen_patch_object LongString.set + (* Translate structured constants *) let rec transl_const = function diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index b4268f4f..e3c33d23 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: symtable.mli 11306 2011-12-13 17:50:08Z frisch $ *) - (* Assign locations and numbers to globals and primitives *) open Cmo_format @@ -20,6 +18,7 @@ open Cmo_format val init: unit -> unit val patch_object: string -> (reloc_info * int) list -> unit +val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array val output_global_map: out_channel -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 7030513d..ec40912c 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,9 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml 12518 2012-05-30 15:55:22Z lefessan $ *) - -open Misc open Asttypes open Types open Typedtree @@ -50,7 +47,7 @@ let lfield v i = Lprim(Pfield i, [Lvar v]) let transl_label l = share (Const_immstring l) -let rec transl_meth_list lst = +let transl_meth_list lst = if lst = [] then Lconst (Const_pointer 0) else share (Const_block (0, List.map (fun lab -> Const_immstring lab) lst)) @@ -362,11 +359,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = cl_init)) end -let rec build_class_lets cl = +let rec build_class_lets cl ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> - let env, wrap = build_class_lets cl in - (env, fun x -> Translcore.transl_let rec_flag defs (wrap x)) + Tcl_let (rec_flag, defs, vals, cl') -> + 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))) | _ -> (cl.cl_env, fun x -> x) @@ -595,7 +596,7 @@ let transl_class ids cl_id pub_meths cl vflag = 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 in + let cl_env, llets = build_class_lets cl ids 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 @@ -662,8 +663,6 @@ let transl_class ids cl_id pub_meths cl vflag = let cla = Ident.create "class" in let (inh_init, obj_init) = build_object_init_0 cla [] cl copy_env subst_env top ids in - if not (Translcore.check_recursive_lambda ids obj_init) then - raise(Error(cl.cl_loc, Illegal_class_expr)); let inh_init' = List.rev inh_init in let (inh_init', cl_init) = build_class_init cla true ([],[]) inh_init' obj_init msubst top cl @@ -817,7 +816,7 @@ open Format let report_error ppf = function | Illegal_class_expr -> - fprintf ppf "This kind of class expression is not allowed" + 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 c856e85b..f7858da2 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *) - open Typedtree open Lambda diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 520e2528..36b79daa 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,15 +10,12 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml 12871 2012-08-21 07:14:03Z lefessan $ *) - (* Translation from typed abstract syntax to lambda terms, for the core language *) open Misc open Asttypes open Primitive -open Path open Types open Typedtree open Typeopt @@ -153,6 +150,11 @@ let primitives_table = create_hashtable 57 [ "%sequand", Psequand; "%sequor", Psequor; "%boolnot", Pnot; + "%big_endian", Pctconst Big_endian; + "%word_size", Pctconst Word_size; + "%ostype_unix", Pctconst Ostype_unix; + "%ostype_win32", Pctconst Ostype_win32; + "%ostype_cygwin", Pctconst Ostype_cygwin; "%negint", Pnegint; "%succint", Poffsetint 1; "%predint", Poffsetint(-1); @@ -275,7 +277,38 @@ let primitives_table = create_hashtable 57 [ "%caml_ba_unsafe_set_2", Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); "%caml_ba_unsafe_set_3", - Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout) + Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_dim_1", Pbigarraydim(1); + "%caml_ba_dim_2", Pbigarraydim(2); + "%caml_ba_dim_3", Pbigarraydim(3); + "%caml_string_get16", Pstring_load_16(false); + "%caml_string_get16u", Pstring_load_16(true); + "%caml_string_get32", Pstring_load_32(false); + "%caml_string_get32u", Pstring_load_32(true); + "%caml_string_get64", Pstring_load_64(false); + "%caml_string_get64u", Pstring_load_64(true); + "%caml_string_set16", Pstring_set_16(false); + "%caml_string_set16u", Pstring_set_16(true); + "%caml_string_set32", Pstring_set_32(false); + "%caml_string_set32u", Pstring_set_32(true); + "%caml_string_set64", Pstring_set_64(false); + "%caml_string_set64u", Pstring_set_64(true); + "%caml_bigstring_get16", Pbigstring_load_16(false); + "%caml_bigstring_get16u", Pbigstring_load_16(true); + "%caml_bigstring_get32", Pbigstring_load_32(false); + "%caml_bigstring_get32u", Pbigstring_load_32(true); + "%caml_bigstring_get64", Pbigstring_load_64(false); + "%caml_bigstring_get64u", Pbigstring_load_64(true); + "%caml_bigstring_set16", Pbigstring_set_16(false); + "%caml_bigstring_set16u", Pbigstring_set_16(true); + "%caml_bigstring_set32", Pbigstring_set_32(false); + "%caml_bigstring_set32u", Pbigstring_set_32(true); + "%caml_bigstring_set64", Pbigstring_set_64(false); + "%caml_bigstring_set64u", Pbigstring_set_64(true); + "%bswap16", Pbswap16; + "%bswap_int32", Pbbswap(Pint32); + "%bswap_int64", Pbbswap(Pint64); + "%bswap_native", Pbbswap(Pnativeint); ] let prim_makearray = @@ -300,10 +333,10 @@ let transl_prim loc prim args = simplify_constant_constructor) = Hashtbl.find comparisons_table prim_name in begin match args with - [arg1; {exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}] + [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}] when simplify_constant_constructor -> intcomp - | [{exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}; arg2] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2] when simplify_constant_constructor -> intcomp | [arg1; {exp_desc = Texp_variant(_, None)}] @@ -371,12 +404,14 @@ let transl_primitive loc p = match prim with Plazyforce -> let parm = Ident.create "prim" in - Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + Lfunction(Curried, [parm], + Matching.inline_lazy_force (Lvar parm) Location.none) | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in let params = make_params p.prim_arity in - Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) + Lfunction(Curried, params, + Lprim(prim, List.map (fun id -> Lvar id) params)) (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -579,12 +614,14 @@ and transl_exp0 e = if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)) + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], + e.exp_loc)) else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in Lfunction(Curried, [obj; meth; cache; pos], - Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)) + Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], + e.exp_loc)) else transl_primitive e.exp_loc p | Texp_ident(path, _, {val_kind = Val_anc _}) -> @@ -604,7 +641,8 @@ and transl_exp0 e = transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs) + | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn, + oargs) when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> let args, args' = cut p.prim_arity oargs in @@ -615,7 +653,8 @@ and transl_exp0 e = in let wrap0 f = if args' = [] then f else wrap f in - let args = List.map (function _, Some x, _ -> x | _ -> assert false) args in + let args = + List.map (function _, Some x, _ -> x | _ -> assert false) args in let argl = transl_list args in let public_send = p.prim_name = "%send" || not !Clflags.native_code && p.prim_name = "%sendcache"in @@ -628,6 +667,12 @@ and transl_exp0 e = wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin + if p.prim_name = "%sequand" && Path.last path = "&" then + Location.prerr_warning fn.exp_loc + (Warnings.Deprecated "operator (&); you should use (&&) instead"); + if p.prim_name = "%sequor" && Path.last path = "or" then + Location.prerr_warning fn.exp_loc + (Warnings.Deprecated "operator (or); you should use (||) instead"); let prim = transl_prim e.exp_loc p args in match (prim, args) with (Praise, [arg1]) -> @@ -660,7 +705,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end - | Texp_construct(_, _, cstr, args, _) -> + | Texp_construct(_, cstr, args, _) -> let ll = transl_list args in begin match cstr.cstr_tag with Cstr_constant n -> @@ -687,17 +732,17 @@ and transl_exp0 e = Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_int tag)); lam]) end - | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> + | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" - | Texp_field(arg, _, _, lbl) -> + | Texp_field(arg, _, lbl) -> let access = match lbl.lbl_repres with Record_regular -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos in Lprim(access, [transl_exp arg]) - | Texp_setfield(arg, _, _, lbl, newval) -> + | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) @@ -788,7 +833,7 @@ and transl_exp0 e = ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) | Texp_function(_, _, _) - | Texp_construct (_, _, {cstr_arity = 0}, _, _) + | Texp_construct (_, {cstr_arity = 0}, _, _) -> transl_exp e | Texp_constant(Const_float _) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) @@ -979,11 +1024,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = done end; List.iter - (fun (_, _, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) + (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr) lbl_expr_list; let ll = Array.to_list lv in let mut = - if List.exists (fun (_, _, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list + if List.exists (fun (_, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list then Mutable else Immutable in let lam = @@ -1008,7 +1053,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = (* 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 rec update_field (_, _, lbl, expr) cont = + let update_field (_, lbl, expr) cont = let upd = match lbl.lbl_repres with Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 7203dcb9..f766cdcf 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -10,13 +10,10 @@ (* *) (***********************************************************************) -(* $Id: translcore.mli 12871 2012-08-21 07:14:03Z lefessan $ *) - (* Translation from typed abstract syntax to lambda terms, for the core language *) open Asttypes -open Types open Typedtree open Lambda diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index fe4a2017..3b94a915 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translmod.ml 12871 2012-08-21 07:14:03Z lefessan $ *) - (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -21,7 +19,6 @@ open Longident open Path open Types open Typedtree -open Primitive open Lambda open Translobj open Translcore @@ -82,7 +79,8 @@ let rec compose_coercions c1 c2 = let primitive_declarations = ref ([] : Primitive.description list) let record_primitive = function - | {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations + | {val_kind=Val_prim p} -> + primitive_declarations := p :: !primitive_declarations | _ -> () (* Keep track of the root path (from the root of the namespace to the @@ -230,6 +228,19 @@ let compile_recmodule compile_rhs bindings cont = bindings)) cont +(* Extract the list of "value" identifiers bound by a signature. + "Value" identifiers are identifiers for signature components that + correspond to a run-time value: values, exceptions, modules, classes. + Note: manifest primitives do not correspond to a run-time value! *) + +let rec bound_value_identifiers = function + [] -> [] + | Sig_value(id, {val_kind = Val_reg}) :: rem -> + id :: bound_value_identifiers rem + | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | _ :: rem -> bound_value_identifiers rem (* Compile a module expression *) @@ -309,7 +320,8 @@ and transl_structure fields cc rootpath = function transl_module Tcoerce_none (field_path rootpath id) modl, transl_structure (id :: fields) cc rootpath rem) | Tstr_recmodule bindings -> - let ext_fields = List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in + let ext_fields = + List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in compile_recmodule (fun id modl -> transl_module Tcoerce_none (field_path rootpath id) modl) @@ -317,7 +329,7 @@ and transl_structure fields cc rootpath = function (transl_structure ext_fields cc rootpath rem) | Tstr_modtype(id, _, decl) -> transl_structure fields cc rootpath rem - | Tstr_open (path, _) -> + | Tstr_open _ -> transl_structure fields cc rootpath rem | Tstr_class cl_list -> let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in @@ -330,7 +342,8 @@ and transl_structure fields cc rootpath = function transl_structure (List.rev ids @ fields) cc rootpath rem) | Tstr_class_type cl_list -> transl_structure fields cc rootpath rem - | Tstr_include(modl, ids) -> + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -355,6 +368,77 @@ let transl_implementation module_name (str, cc) = [transl_label_init (transl_struct [] cc (global_path module_id) str)]) + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +let rec defined_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> defined_idents rem + | Tstr_value(rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ defined_idents rem + | Tstr_primitive(id, _, descr) -> defined_idents rem + | Tstr_type decls -> defined_idents rem + | Tstr_exception(id, _, decl) -> id :: defined_idents rem + | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem + | Tstr_module(id, _, modl) -> id :: defined_idents rem + | Tstr_recmodule decls -> + List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem + | Tstr_modtype(id, _, decl) -> defined_idents rem + | Tstr_open _ -> defined_idents rem + | Tstr_class cl_list -> + List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem + | Tstr_class_type cl_list -> defined_idents rem + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem + +(* second level idents (module M = struct ... let id = ... end), + and all sub-levels idents *) +let rec more_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> more_idents rem + | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem + | Tstr_primitive(id, _, descr) -> more_idents rem + | Tstr_type decls -> more_idents rem + | Tstr_exception(id, _, decl) -> more_idents rem + | Tstr_exn_rebind(id, _, path, _) -> more_idents rem + | Tstr_recmodule decls -> more_idents rem + | Tstr_modtype(id, _, decl) -> more_idents rem + | Tstr_open _ -> more_idents rem + | Tstr_class cl_list -> more_idents rem + | Tstr_class_type cl_list -> more_idents rem + | Tstr_include(modl, _) -> more_idents rem + | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> + all_idents str.str_items @ more_idents rem + | Tstr_module(id, _, _) -> more_idents rem + +and all_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval expr -> all_idents rem + | Tstr_value(rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ all_idents rem + | Tstr_primitive(id, _, descr) -> all_idents rem + | Tstr_type decls -> all_idents rem + | Tstr_exception(id, _, decl) -> id :: all_idents rem + | Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem + | Tstr_recmodule decls -> + List.map (fun (id, _, _, _) -> id) decls @ all_idents rem + | Tstr_modtype(id, _, decl) -> all_idents rem + | Tstr_open _ -> all_idents rem + | Tstr_class cl_list -> + List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem + | Tstr_class_type cl_list -> all_idents rem + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem + | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> + id :: all_idents str.str_items @ all_idents rem + | Tstr_module(id, _, _) -> id :: all_idents rem + + (* A variant of transl_structure used to compile toplevel structure definitions for the native-code compiler. Store the defined values in the fields of the global as soon as they are defined, in order to reduce register @@ -376,7 +460,7 @@ let nat_toplevel_name id = fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) let transl_store_structure glob map prims str = - let rec transl_store subst = function + let rec transl_store rootpath subst = function [] -> transl_store_subst := subst; lambda_unit @@ -384,28 +468,41 @@ let transl_store_structure glob map prims str = match item.str_desc with | Tstr_eval expr -> Lsequence(subst_lambda subst (transl_exp expr), - transl_store subst rem) + transl_store rootpath subst rem) | Tstr_value(rec_flag, pat_expr_list) -> let ids = let_bound_idents pat_expr_list in let lam = transl_let rec_flag pat_expr_list (store_idents ids) in Lsequence(subst_lambda subst lam, - transl_store (add_idents false ids subst) rem) + transl_store rootpath (add_idents false ids subst) rem) | Tstr_primitive(id, _, descr) -> record_primitive descr.val_val; - transl_store subst rem + transl_store rootpath subst rem | Tstr_type(decls) -> - transl_store subst rem + transl_store rootpath subst rem | Tstr_exception( id, _, decl) -> - let lam = transl_exception id (field_path (global_path glob) id) decl in + let lam = transl_exception id (field_path rootpath id) decl in Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store (add_ident false id subst) rem) + transl_store rootpath (add_ident false id subst) rem) | Tstr_exn_rebind( id, _, path, _) -> let lam = subst_lambda subst (transl_path path) in Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store (add_ident false id subst) rem) + transl_store rootpath (add_ident false id subst) rem) + | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> + let lam = transl_store (field_path rootpath id) subst str.str_items in + (* Careful: see next case *) + let subst = !transl_store_subst in + Lsequence(lam, + Llet(Strict, id, + subst_lambda subst + (Lprim(Pmakeblock(0, Immutable), + List.map (fun id -> Lvar id) + (defined_idents str.str_items))), + Lsequence(store_ident id, + transl_store rootpath (add_ident true id subst) + rem))) | Tstr_module( id, _, modl) -> let lam = - transl_module Tcoerce_none (field_path (global_path glob) id) modl in + transl_module Tcoerce_none (field_path rootpath id) modl in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. If so, keep using the local module value (id) in the remainder of @@ -413,21 +510,22 @@ let transl_store_structure glob map prims str = If not, we can use the value from the global (add_ident true adds id -> Pgetglobal... to subst). *) Llet(Strict, id, subst_lambda subst lam, - Lsequence(store_ident id, transl_store(add_ident true id subst) rem)) + Lsequence(store_ident id, + transl_store rootpath (add_ident true id subst) rem)) | Tstr_recmodule bindings -> let ids = List.map fst4 bindings in compile_recmodule (fun id modl -> subst_lambda subst (transl_module Tcoerce_none - (field_path (global_path glob) id) modl)) + (field_path rootpath id) modl)) bindings (Lsequence(store_idents ids, - transl_store (add_idents true ids subst) rem)) + transl_store rootpath (add_idents true ids subst) rem)) | Tstr_modtype(id, _, decl) -> - transl_store subst rem - | Tstr_open (path, _) -> - transl_store subst rem + transl_store rootpath subst rem + | Tstr_open _ -> + transl_store rootpath subst rem | Tstr_class cl_list -> let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in let lam = @@ -439,13 +537,14 @@ let transl_store_structure glob map prims str = cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, - transl_store (add_idents false ids subst) rem) + transl_store rootpath (add_idents false ids subst) rem) | Tstr_class_type cl_list -> - transl_store subst rem - | Tstr_include(modl, ids) -> + transl_store rootpath subst rem + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec store_idents pos = function - [] -> transl_store (add_idents true ids subst) rem + [] -> transl_store rootpath (add_idents true ids subst) rem | id :: idl -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), Lsequence(store_ident id, store_idents (pos + 1) idl)) in @@ -484,31 +583,8 @@ let transl_store_structure glob map prims str = transl_primitive Location.none prim]), cont) - in List.fold_right store_primitive prims (transl_store !transl_store_subst str) - -(* Build the list of value identifiers defined by a toplevel structure - (excluding primitive declarations). *) - -let rec defined_idents items = - match items with - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval expr -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> - let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive(id, _, descr) -> defined_idents rem - | Tstr_type decls -> defined_idents rem - | Tstr_exception(id, _, decl) -> id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem - | Tstr_module(id, _, modl) -> id :: defined_idents rem - | Tstr_recmodule decls -> List.map fst4 decls @ defined_idents rem - | Tstr_modtype(id, _, decl) -> defined_idents rem - | Tstr_open (path, _) -> defined_idents rem - | Tstr_class cl_list -> - List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, ids) -> ids @ defined_idents rem + in List.fold_right store_primitive prims + (transl_store (global_path glob) !transl_store_subst str) (* Transform a coercion and the list of value identifiers defined by a toplevel structure into a table [id -> (pos, coercion)], @@ -522,29 +598,32 @@ let rec defined_idents items = Also compute the total size of the global block, and the list of all primitives exported as values. *) -let build_ident_map restr idlist = +let build_ident_map restr idlist more_ids = let rec natural_map pos map prims = function [] -> (map, prims, pos) | id :: rem -> natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in - match restr with - Tcoerce_none -> - natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> - let idarray = Array.of_list idlist in - let rec export_map pos map prims undef = function + let (map, prims, pos) = + match restr with + Tcoerce_none -> + natural_map 0 Ident.empty [] idlist + | Tcoerce_structure pos_cc_list -> + let idarray = Array.of_list idlist in + let rec export_map pos map prims undef = function [] -> natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> - export_map (pos + 1) map ((pos, p) :: prims) undef rem - | (source_pos, cc) :: rem -> - let id = idarray.(source_pos) in - export_map (pos + 1) (Ident.add id (pos, cc) map) - prims (list_remove id undef) rem - in export_map 0 Ident.empty [] idlist pos_cc_list - | _ -> - fatal_error "Translmod.build_ident_map" + | (source_pos, Tcoerce_primitive p) :: rem -> + export_map (pos + 1) map ((pos, p) :: prims) undef rem + | (source_pos, cc) :: rem -> + let id = idarray.(source_pos) in + export_map (pos + 1) (Ident.add id (pos, cc) map) + prims (list_remove id undef) rem + in export_map 0 Ident.empty [] idlist pos_cc_list + | _ -> + fatal_error "Translmod.build_ident_map" + in + natural_map pos map prims more_ids (* Compile an implementation using transl_store_structure (for the native-code compiler). *) @@ -553,7 +632,8 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl = reset_labels (); primitive_declarations := []; let module_id = Ident.create_persistent module_name in - let (map, prims, size) = build_ident_map restr (defined_idents str) in + let (map, prims, size) = + build_ident_map restr (defined_idents str) (more_idents str) in let f = function | [ { str_desc = Tstr_eval expr } ] when topl -> assert (size = 0); @@ -636,7 +716,7 @@ let transl_toplevel_item item = (make_sequence toploop_setvalue_id idents) | Tstr_modtype(id, _, decl) -> lambda_unit - | Tstr_open (path, _) -> + | Tstr_open _ -> lambda_unit | Tstr_class cl_list -> (* we need to use unique names for the classes because there might @@ -654,7 +734,8 @@ let transl_toplevel_item item = cl_list) | Tstr_class_type cl_list -> lambda_unit - | Tstr_include(modl, ids) -> + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec set_idents pos = function [] -> @@ -723,5 +804,6 @@ open Format let report_error ppf = function Circular_dependency id -> fprintf ppf - "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]" + "@[Cannot safely evaluate the definition@ \ + of the recursively-defined module %a@]" Printtyp.ident id diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index aa98114b..8e500554 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translmod.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Translation from typed abstract syntax to lambda terms, for the module language *) diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 7bd61aa6..97fdeb5d 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translobj.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Misc open Primitive open Asttypes diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 7cd986f3..55c16343 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: translobj.mli 11156 2011-07-27 14:17:02Z doligez $ *) - open Lambda val oo_prim: string -> lambda diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 21498bd9..e9b7405f 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -10,13 +10,8 @@ (* *) (***********************************************************************) -(* $Id: typeopt.ml 11210 2011-09-22 09:05:42Z garrigue $ *) - (* Auxiliaries for type-based optimizations, e.g. array kinds *) -open Misc -open Asttypes -open Primitive open Path open Types open Typedtree @@ -125,6 +120,7 @@ let bigarray_kind_and_layout exp = match scrape exp.exp_env exp.exp_type with | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> (bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown, - bigarray_decode_type exp.exp_env layout_type layout_table Pbigarray_unknown_layout) + bigarray_decode_type exp.exp_env layout_type layout_table + Pbigarray_unknown_layout) | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli index f6148d82..a90df8ae 100644 --- a/bytecomp/typeopt.mli +++ b/bytecomp/typeopt.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: typeopt.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Auxiliaries for type-based optimizations, e.g. array kinds *) val has_base_type : Typedtree.expression -> Path.t -> bool diff --git a/byterun/.depend b/byterun/.depend index 68adc27b..2f1780db 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -123,7 +123,7 @@ startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h + ../config/s.h mlvalues.h fail.h int64_native.h sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -135,6 +135,9 @@ unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h +win32.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h @@ -262,7 +265,7 @@ startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h + ../config/s.h mlvalues.h fail.h int64_native.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -274,6 +277,9 @@ unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h +win32.d.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h @@ -399,7 +405,7 @@ startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h + ../config/s.h mlvalues.h fail.h int64_native.h sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -411,3 +417,6 @@ unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h +win32.pic.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h diff --git a/byterun/Makefile b/byterun/Makefile index 2d1006ec..c5fa41bd 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile 12566 2012-06-04 16:33:59Z doligez $ - include Makefile.common CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) diff --git a/byterun/Makefile.common b/byterun/Makefile.common index b519f75b..35e66506 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.common 12265 2012-03-24 08:13:21Z xleroy $ - include ../config/Makefile CC=$(BYTECC) @@ -71,9 +69,23 @@ install-runtimed: cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed +# If primitives contain duplicated lines (e.g. because the code is defined +# like +# #ifdef X +# CAMLprim value caml_foo() ... +# #else +# CAMLprim value caml_foo() ... +# end), horrible things will happen (duplicated entries in Runtimedef -> +# double registration in Symtable -> empty entry in the PRIM table -> +# the bytecode interpreter is confused). +# We sort the primitive file and remove duplicates to avoid this problem. + +# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC +# port, the "sort" program in the path is Microsoft's and not cygwin's + primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ - $(PRIMS) > primitives + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \ + | sort | uniq > primitives prims.c : primitives (echo '#include "mlvalues.h"'; \ diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index fc3c766d..af288188 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $ - include Makefile.common CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) @@ -22,10 +20,12 @@ OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) - $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A) + $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) \ + $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) + $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ + $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) $(call MKLIB,libcamlrun.$(A),$(OBJS)) @@ -44,11 +44,13 @@ libcamlrund.$(A): $(DOBJS) .depend.nt: .depend rm -f .depend.win32 - echo "win32.o: win32.c fail.h compatibility.h misc.h config.h \\" >> .depend.win32 - echo " ../config/m.h ../config/s.h mlvalues.h memory.h gc.h \\" >> .depend.win32 - echo " major_gc.h freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 + echo "win32.o: win32.c fail.h compatibility.h \\" >> .depend.win32 + echo " misc.h config.h ../config/m.h ../config/s.h \\" >> .depend.win32 + echo " mlvalues.h memory.h gc.h major_gc.h \\" >> .depend.win32 + echo " freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 cat .depend >> .depend.win32 - sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' .depend.win32 > .depend.nt + sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \ + .depend.win32 > .depend.nt rm -f .depend.win32 include .depend.nt diff --git a/byterun/alloc.c b/byterun/alloc.c index abec6aed..a1fd2f03 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: alloc.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. 2. Convenience functions related to allocation. diff --git a/byterun/alloc.h b/byterun/alloc.h index 029052c2..a0cd41b6 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: alloc.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_ALLOC_H #define CAML_ALLOC_H diff --git a/byterun/array.c b/byterun/array.c index 69a38346..c9d991ed 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: array.c 11914 2011-12-21 10:41:59Z xleroy $ */ - /* Operations on arrays */ #include @@ -321,11 +319,12 @@ static value caml_array_gather(intnat num_arrays, count--, src++, pos++) { caml_initialize(&Field(res, pos), *src); } - /* 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. */ - res = caml_check_urgent_gc(res); } Assert(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. */ + res = caml_check_urgent_gc(res); } CAMLreturn (res); } diff --git a/byterun/backtrace.c b/byterun/backtrace.c index bcb0f05d..4098e47e 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -11,17 +11,18 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c 12149 2012-02-10 16:15:24Z doligez $ */ - /* Stack backtrace for uncaught exceptions */ +#include #include #include -#include +#include + #include "config.h" #ifdef HAS_UNISTD #include #endif + #include "mlvalues.h" #include "alloc.h" #include "io.h" @@ -106,6 +107,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; if (pc >= caml_start_code && pc < end_code){ + /* testing the code region is needed: PR#1554 */ caml_backtrace_buffer[caml_backtrace_pos++] = pc; } for (/*nothing*/; sp < caml_trapsp; sp++) { @@ -117,6 +119,74 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } } +/* returns the next frame pointer (or NULL if none is available); + updates *sp to point to the following one, and *trapsp to the next + trap frame, which we will skip when we reach it */ + +code_t caml_next_frame_pointer(value ** sp, value ** trapsp) +{ + code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); + + while (*sp < caml_stack_high) { + code_t *p = (code_t*) (*sp)++; + if(&Trap_pc(*trapsp) == p) { + *trapsp = Trap_link(*trapsp); + continue; + } + if (*p >= caml_start_code && *p < end_code) return *p; + } + return NULL; +} + +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ + +CAMLprim value caml_get_current_callstack(value max_frames_value) { + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + value * sp = caml_extern_sp; + value * trapsp = caml_trapsp; + + for (trace_size = 0; trace_size < max_frames; trace_size++) { + code_t p = caml_next_frame_pointer(&sp, &trapsp); + if (p == NULL) break; + } + } + + trace = caml_alloc(trace_size, Abstract_tag); + + /* then collect the trace */ + { + value * sp = caml_extern_sp; + value * trapsp = caml_trapsp; + uintnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + code_t p = caml_next_frame_pointer(&sp, &trapsp); + Assert(p != NULL); + /* The assignment below is safe without [caml_initialize], even + if the trace is large and allocated on the old heap, because + we assign values that are outside the OCaml heap. */ + Assert(!(Is_block((value) p) && Is_in_heap((value) p))); + Field(trace, trace_pos) = (value) p; + } + } + + CAMLreturn(trace); +} + /* Read the debugging info contained in the current bytecode executable. Return an OCaml array of OCaml lists of debug_event records in "events", or Val_false on failure. */ @@ -125,6 +195,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) #define O_BINARY 0 #endif +static char *read_debug_info_error = ""; static value read_debug_info(void) { CAMLparam0(); @@ -142,10 +213,14 @@ static value read_debug_info(void) exec_name = caml_exe_name; } fd = caml_attempt_open(&exec_name, &trail, 1); - if (fd < 0) CAMLreturn(Val_false); + if (fd < 0){ + read_debug_info_error = "executable program file not found"; + CAMLreturn(Val_false); + } caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); + read_debug_info_error = "program not linked with -g"; CAMLreturn(Val_false); } chan = caml_open_descriptor_in(fd); @@ -224,7 +299,7 @@ static void extract_location_info(value events, code_t pc, - Int_val (Field (ev_start, POS_BOL)); } -/* Print location information */ +/* Print location information -- same behavior as in Printexc */ static void print_location(struct loc_info * li, int index) { @@ -264,8 +339,8 @@ CAMLexport void caml_print_exception_backtrace(void) events = read_debug_info(); if (events == Val_false) { - fprintf(stderr, - "(Program not linked with -g, cannot print stack backtrace)\n"); + fprintf(stderr, "(Cannot print stack backtrace: %s)\n", + read_debug_info_error); return; } for (i = 0; i < caml_backtrace_pos; i++) { @@ -276,9 +351,9 @@ CAMLexport void caml_print_exception_backtrace(void) /* Convert the backtrace to a data structure usable from OCaml */ -CAMLprim value caml_get_exception_backtrace(value unit) +CAMLprim value caml_convert_raw_backtrace(value backtrace) { - CAMLparam0(); + CAMLparam1(backtrace); CAMLlocal5(events, res, arr, p, fname); int i; struct loc_info li; @@ -287,9 +362,9 @@ CAMLprim value caml_get_exception_backtrace(value unit) if (events == Val_false) { res = Val_int(0); /* None */ } else { - arr = caml_alloc(caml_backtrace_pos, 0); - for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info(events, caml_backtrace_buffer[i], &li); + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + extract_location_info(events, (code_t)Field(backtrace, i), &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); p = caml_alloc_small(5, 0); @@ -308,3 +383,27 @@ CAMLprim value caml_get_exception_backtrace(value unit) } CAMLreturn(res); } + +/* Get a copy of the latest backtrace */ + +CAMLprim value caml_get_exception_raw_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal1(res); + res = caml_alloc(caml_backtrace_pos, Abstract_tag); + if(caml_backtrace_buffer != NULL) + memcpy(&Field(res, 0), caml_backtrace_buffer, + caml_backtrace_pos * sizeof(code_t)); + CAMLreturn(res); +} + +/* the function below is deprecated: see asmrun/backtrace.c */ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal2(raw, res); + raw = caml_get_exception_raw_backtrace(unit); + res = caml_convert_raw_backtrace(raw); + CAMLreturn(res); +} diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 3abc675b..158ca285 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_BACKTRACE_H #define CAML_BACKTRACE_H diff --git a/byterun/callback.c b/byterun/callback.c index abc85dfe..3bd7ea45 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: callback.c 12149 2012-02-10 16:15:24Z doligez $ */ - /* Callbacks from C to OCaml */ #include diff --git a/byterun/callback.h b/byterun/callback.h index 06b60d68..ded0b980 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: callback.h 12149 2012-02-10 16:15:24Z doligez $ */ - /* Callbacks from C to OCaml */ #ifndef CAML_CALLBACK_H diff --git a/byterun/compact.c b/byterun/compact.c index dec89e6f..bf803017 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: compact.c 12910 2012-09-10 09:52:09Z doligez $ */ - #include #include "config.h" diff --git a/byterun/compact.h b/byterun/compact.h index ee1b7005..2abac167 100644 --- a/byterun/compact.h +++ b/byterun/compact.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: compact.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_COMPACT_H #define CAML_COMPACT_H diff --git a/byterun/compare.c b/byterun/compare.c index 88b0bea6..6593ed9a 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: compare.c 12081 2012-01-26 14:13:51Z doligez $ */ - #include #include #include "custom.h" diff --git a/byterun/compare.h b/byterun/compare.h index e2ab53e3..41d6a0c9 100644 --- a/byterun/compare.h +++ b/byterun/compare.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: compare.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_COMPARE_H #define CAML_COMPARE_H diff --git a/byterun/compatibility.h b/byterun/compatibility.h index b0728560..58bf2834 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: compatibility.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* definitions for compatibility with old identifiers */ #ifndef CAML_COMPATIBILITY_H diff --git a/byterun/config.h b/byterun/config.h index 9d017efc..24f4e593 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: config.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_CONFIG_H #define CAML_CONFIG_H @@ -96,7 +94,8 @@ typedef struct { uint32 l, h; } uint64, int64; /* We use threaded code interpretation if the compiler provides labels as first-class values (GCC 2.x). */ -#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ + && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) #define THREADED_CODE #endif diff --git a/byterun/custom.c b/byterun/custom.c index 41813a1b..e4f9eaf5 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: custom.c 12658 2012-07-06 16:44:24Z xleroy $ */ - #include #include "alloc.h" diff --git a/byterun/custom.h b/byterun/custom.h index c5b53ef3..ff3cd89a 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: custom.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_CUSTOM_H #define CAML_CUSTOM_H diff --git a/byterun/debugger.c b/byterun/debugger.c index 38d9486a..d64583f2 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: debugger.c 12210 2012-03-08 19:52:03Z doligez $ */ - /* Interface with the byte-code debugger */ #ifdef _WIN32 diff --git a/byterun/debugger.h b/byterun/debugger.h index da09b6be..b5079eb3 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: debugger.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Interface with the debugger */ #ifndef CAML_DEBUGGER_H diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 5cb2ed7d..f07cf91e 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: dynlink.c 12677 2012-07-09 14:15:48Z doligez $ */ - /* Dynamic loading of C primitives. */ #include @@ -165,7 +163,7 @@ void caml_build_primitive_table(char * lib_path, for (p = req_prims; *p != 0; p += strlen(p) + 1) { c_primitive prim = lookup_primitive(p); 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", p); caml_ext_table_add(&caml_prim_table, (void *) prim); #ifdef DEBUG caml_ext_table_add(&caml_prim_name_table, strdup(p)); @@ -190,7 +188,8 @@ void caml_build_primitive_table_builtin(void) for (i = 0; caml_builtin_cprim[i] != 0; i++) { 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_ext_table_add(&caml_prim_name_table, + strdup(caml_names_of_builtin_cprim[i])); #endif } } diff --git a/byterun/dynlink.h b/byterun/dynlink.h index f3909247..74cfdb66 100644 --- a/byterun/dynlink.h +++ b/byterun/dynlink.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: dynlink.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Dynamic loading of C primitives. */ #ifndef CAML_DYNLINK_H diff --git a/byterun/exec.h b/byterun/exec.h index 43c6d374..8b50484d 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: exec.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* exec.h : format of executable bytecode files */ #ifndef CAML_EXEC_H diff --git a/byterun/extern.c b/byterun/extern.c index bf9f47d4..33fa89a9 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: extern.c 12800 2012-07-30 18:59:07Z doligez $ */ - /* Structured output */ /* The interface of this file is "intext.h" */ @@ -34,8 +32,16 @@ static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ static uintnat size_64; /* Size in words of 64-bit block for struct. */ -static int extern_ignore_sharing; /* Flag to ignore sharing */ -static int extern_closures; /* Flag to allow externing code pointers */ +/* Flags affecting marshaling */ + +enum { + NO_SHARING = 1, /* Flag to ignore sharing */ + CLOSURES = 2, /* Flag to allow marshaling code pointers */ + COMPAT_32 = 4 /* Flag to ensure that output can safely + be read back on a 32-bit platform */ +}; + +static int extern_flags; /* logical or of some of the flags above */ /* Trail mechanism to undo forwarding pointers put inside objects */ @@ -155,7 +161,7 @@ static void extern_record_location(value obj) { header_t hdr; - if (extern_ignore_sharing) return; + if (extern_flags & NO_SHARING) return; if (extern_trail_cur == extern_trail_limit) { struct trail_block * new_block = malloc(sizeof(struct trail_block)); if (new_block == NULL) extern_out_of_memory(); @@ -371,7 +377,10 @@ static void extern_rec(value v) } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16(CODE_INT16, n); #ifdef ARCH_SIXTYFOUR - } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { + } else if (n < -((intnat)1 << 30) || n >= ((intnat)1 << 30)) { + if (extern_flags & COMPAT_32) + extern_failwith("output_value: integer cannot be read back on " + "32-bit platform"); writecode64(CODE_INT64, n); #endif } else @@ -426,6 +435,11 @@ static void extern_rec(value v) } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { +#ifdef ARCH_SIXTYFOUR + if (len > 0xFFFFFB && (extern_flags & COMPAT_32)) + extern_failwith("output_value: string cannot be read back on " + "32-bit platform"); +#endif writecode32(CODE_STRING32, len); } writeblock(String_val(v), len); @@ -452,6 +466,11 @@ static void extern_rec(value v) if (nfloats < 0x100) { writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats); } else { +#ifdef ARCH_SIXTYFOUR + if (nfloats > 0x1FFFFF && (extern_flags & COMPAT_32)) + extern_failwith("output_value: float array cannot be read back on " + "32-bit platform"); +#endif writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); } writeblock_float8((double *) v, nfloats); @@ -465,8 +484,8 @@ static void extern_rec(value v) break; case Infix_tag: writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); - extern_rec(v - Infix_offset_hd(hd)); - break; + v = v - Infix_offset_hd(hd); /* PR#5772 */ + continue; case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; @@ -489,9 +508,15 @@ static void extern_rec(value v) Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR } else if (hd >= ((uintnat)1 << 32)) { + /* Is this case useful? The overflow check in extern_value will fail.*/ writecode64(CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { +#ifdef ARCH_SIXTYFOUR + if (sz > 0x3FFFFF && (extern_flags & COMPAT_32)) + extern_failwith("output_value: array cannot be read back on " + "32-bit platform"); +#endif writecode32(CODE_BLOCK32, Whitehd_hd (hd)); } size_32 += 1 + sz; @@ -512,7 +537,7 @@ static void extern_rec(value v) } } else if ((cf = extern_find_code((char *) v)) != NULL) { - if (!extern_closures) + 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); @@ -532,17 +557,13 @@ static void extern_rec(value v) /* Never reached as function leaves with return */ } -enum { NO_SHARING = 1, CLOSURES = 2 }; -static int extern_flags[] = { NO_SHARING, CLOSURES }; +static int extern_flag_values[] = { NO_SHARING, CLOSURES, COMPAT_32 }; static intnat extern_value(value v, value flags) { intnat res_len; - int fl; /* Parse flag list */ - fl = caml_convert_flag_list(flags, extern_flags); - extern_ignore_sharing = fl & NO_SHARING; - extern_closures = fl & CLOSURES; + extern_flags = caml_convert_flag_list(flags, extern_flag_values); /* Initializations */ init_extern_trail(); obj_counter = 0; @@ -585,13 +606,12 @@ static intnat extern_value(value v, value flags) void caml_output_val(struct channel *chan, value v, value flags) { - intnat len; struct output_block * blk, * nextblk; if (! caml_channel_binary_mode(chan)) caml_failwith("output_value: not a binary channel"); init_extern_output(); - len = extern_value(v, flags); + extern_value(v, flags); /* During [caml_really_putblock], concurrent [caml_output_val] operations can take place (via signal handlers or context switching in systhreads), and [extern_output_first] may change. So, save it in a local variable. */ diff --git a/byterun/fail.c b/byterun/fail.c index 1d854169..d721d5c9 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: fail.c 11187 2011-09-08 08:34:43Z xclerc $ */ - /* Raising exceptions from C. */ #include diff --git a/byterun/fail.h b/byterun/fail.h index 75928a2c..68322741 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: fail.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_FAIL_H #define CAML_FAIL_H @@ -65,7 +63,8 @@ extern "C" { CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; -CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) Noreturn; +CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) + Noreturn; CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; CAMLextern void caml_failwith (char const *) Noreturn; CAMLextern void caml_invalid_argument (char const *) Noreturn; diff --git a/byterun/finalise.c b/byterun/finalise.c index 244e5da8..15b7a753 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: finalise.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Handling of finalised values. */ #include "callback.h" diff --git a/byterun/finalise.h b/byterun/finalise.h index 14d62244..96853f52 100644 --- a/byterun/finalise.h +++ b/byterun/finalise.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: finalise.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_FINALISE_H #define CAML_FINALISE_H diff --git a/byterun/fix_code.c b/byterun/fix_code.c index c3142197..746f8b75 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.c 12715 2012-07-16 10:37:03Z frisch $ */ - /* Handling of blocks of bytecode (endianness switch, threading). */ #include "config.h" @@ -34,7 +32,6 @@ code_t caml_start_code; asize_t caml_code_size; unsigned char * caml_saved_code; -unsigned char caml_code_md5[16]; /* Read the main bytecode block from a file */ diff --git a/byterun/fix_code.h b/byterun/fix_code.h index 81124878..419ad327 100644 --- a/byterun/fix_code.h +++ b/byterun/fix_code.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.h 12715 2012-07-16 10:37:03Z frisch $ */ - /* Handling of blocks of bytecode (endianness switch, threading). */ #ifndef CAML_FIX_CODE_H diff --git a/byterun/floats.c b/byterun/floats.c index 1b49b909..9071106f 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: floats.c 12030 2012-01-16 10:23:51Z frisch $ */ - /* The interface of this file is in "mlvalues.h" and "alloc.h" */ #include diff --git a/byterun/freelist.c b/byterun/freelist.c index a67ce86c..1bbbc25f 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: freelist.c 12910 2012-09-10 09:52:09Z doligez $ */ - #define FREELIST_DEBUG 0 #if FREELIST_DEBUG #include @@ -196,7 +194,8 @@ char *caml_fl_allocate (mlsize_t wo_sz) #if FREELIST_DEBUG if (i > 5) fprintf (stderr, "FLP: found at %d size=%d\n", i, wo_sz); #endif - result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next(flp[i])); + result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], + Next (flp[i])); goto update_flp; } } diff --git a/byterun/freelist.h b/byterun/freelist.h index c3479909..146961fa 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: freelist.h 12910 2012-09-10 09:52:09Z doligez $ */ - /* Free lists of heap blocks. */ #ifndef CAML_FREELIST_H diff --git a/byterun/gc.h b/byterun/gc.h index be72d076..3cbf08a2 100644 --- a/byterun/gc.h +++ b/byterun/gc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: gc.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_GC_H #define CAML_GC_H diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 5d6c8245..84327fa2 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c 12708 2012-07-13 12:03:26Z doligez $ */ - #include "alloc.h" #include "compact.h" #include "custom.h" @@ -129,7 +127,10 @@ static value heap_stats (int returnstats) free_words = 0, free_blocks = 0, largest_free = 0, fragments = 0, heap_chunks = 0; char *chunk = caml_heap_start, *chunk_end; - char *cur_hp, *prev_hp; + char *cur_hp; +#ifdef DEBUG + char *prev_hp; +#endif header_t cur_hd; #ifdef DEBUG @@ -139,7 +140,9 @@ static value heap_stats (int returnstats) while (chunk != NULL){ ++ heap_chunks; chunk_end = chunk + Chunk_size (chunk); +#ifdef DEBUG prev_hp = NULL; +#endif cur_hp = chunk; while (cur_hp < chunk_end){ cur_hd = Hd_hp (cur_hp); @@ -194,7 +197,9 @@ static value heap_stats (int returnstats) */ break; } +#ifdef DEBUG prev_hp = cur_hp; +#endif cur_hp = Next (cur_hp); } Assert (cur_hp == chunk_end); chunk = Chunk_next (chunk); @@ -396,7 +401,7 @@ CAMLprim value caml_gc_set(value v) /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ - newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0)))); + newminsize = Bsize_wsize (norm_minsize (Long_val (Field (v, 0)))); if (newminsize != caml_minor_heap_size){ caml_gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024); diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h index e68f425a..5f9d8735 100644 --- a/byterun/gc_ctrl.h +++ b/byterun/gc_ctrl.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_GC_CTRL_H #define CAML_GC_CTRL_H diff --git a/byterun/globroots.c b/byterun/globroots.c index 6ec85054..ded393e8 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: globroots.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Registration of global memory roots */ #include "memory.h" diff --git a/byterun/globroots.h b/byterun/globroots.h index 14ba62ae..1c3ebab2 100644 --- a/byterun/globroots.h +++ b/byterun/globroots.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: globroots.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Registration of global memory roots */ #ifndef CAML_GLOBROOTS_H diff --git a/byterun/hash.c b/byterun/hash.c index 0e4a31ac..61bee20c 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: hash.c 12149 2012-02-10 16:15:24Z doligez $ */ - /* The generic hashing primitive */ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) diff --git a/byterun/hash.h b/byterun/hash.h index 037c9c5a..436a8bb1 100644 --- a/byterun/hash.h +++ b/byterun/hash.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id$ */ - /* Auxiliary functions for custom hash functions */ #ifndef CAML_HASH_H diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 9fc472c9..2934984d 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: instrtrace.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Trace the instructions executed */ #ifdef DEBUG @@ -184,19 +182,19 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) if (prog && v % sizeof (int) == 0 && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) - fprintf (f, "=code@%d", (code_t) v - prog); + fprintf (f, "=code@%ld", (code_t) v - prog); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); else if ((void*)v >= (void*)caml_stack_low && (void*)v < (void*)caml_stack_high) - fprintf (f, "=stack_%d", (intnat*)caml_stack_high - (intnat*)v); + fprintf (f, "=stack_%ld", (intnat*)caml_stack_high - (intnat*)v); else if (Is_block (v)) { int s = Wosize_val (v); int tg = Tag_val (v); int l = 0; switch (tg) { case Closure_tag: - fprintf (f, "=closure[s%d,cod%d]", s, (code_t) (Code_val (v)) - prog); + fprintf (f, "=closure[s%d,cod%ld]", s, (code_t) (Code_val (v)) - prog); goto displayfields; case String_tag: l = caml_string_length (v); @@ -251,11 +249,11 @@ caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen, value *p; fprintf (f, "accu="); caml_trace_value_file (accu, prog, proglen, f); - fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%d:", + fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%ld:", (intnat) sp, caml_stack_high - sp); for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high; p++, i++) { - fprintf (f, "\n[%d] ", caml_stack_high - p); + fprintf (f, "\n[%ld] ", caml_stack_high - p); caml_trace_value_file (*p, prog, proglen, f); }; putc ('\n', f); diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h index 1b637ac1..30201608 100644 --- a/byterun/instrtrace.h +++ b/byterun/instrtrace.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: instrtrace.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Trace the instructions executed */ #ifndef _instrtrace_ @@ -27,5 +25,6 @@ extern intnat caml_icount; void caml_stop_here (void); void caml_disasm_instr (code_t pc); void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); -void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f); +void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, + FILE * f); #endif diff --git a/byterun/instruct.h b/byterun/instruct.h index 062b345c..56860500 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: instruct.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* The instruction set. */ #ifndef CAML_INSTRUCT_H diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index cf5e9036..ba7904a4 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64_emul.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ @@ -272,4 +270,18 @@ static int64 I64_of_double(double f) return res; } +static int64 I64_bswap(int64 x) +{ + int64 res; + res.h = (((x.l & 0x000000FF) << 24) | + ((x.l & 0x0000FF00) << 8) | + ((x.l & 0x00FF0000) >> 8) | + ((x.l & 0xFF000000) >> 24)); + res.l = (((x.h & 0x000000FF) << 24) | + ((x.h & 0x0000FF00) << 8) | + ((x.h & 0x00FF0000) >> 8) | + ((x.h & 0xFF000000) >> 24)); + return res; +} + #endif /* CAML_INT64_EMUL_H */ diff --git a/byterun/int64_format.h b/byterun/int64_format.h index 5d4fc6cd..b0de5272 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64_format.h 11180 2011-09-07 12:04:58Z xleroy $ */ - /* printf-like formatting of 64-bit integers, in case the C library printf() function does not support them. */ diff --git a/byterun/int64_native.h b/byterun/int64_native.h index 14425c3c..e9ffe674 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64_native.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation provided in int64_emul.h */ @@ -51,4 +49,13 @@ #define I64_to_double(x) ((double)(x)) #define I64_of_double(x) ((int64)(x)) +#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ + (((x) & 0x000000000000FF00ULL) << 40) | \ + (((x) & 0x0000000000FF0000ULL) << 24) | \ + (((x) & 0x00000000FF000000ULL) << 8) | \ + (((x) & 0x000000FF00000000ULL) >> 8) | \ + (((x) & 0x0000FF0000000000ULL) >> 24) | \ + (((x) & 0x00FF000000000000ULL) >> 40) | \ + (((x) & 0xFF00000000000000ULL) >> 56)) + #endif /* CAML_INT64_NATIVE_H */ diff --git a/byterun/intern.c b/byterun/intern.c index 7395d986..bfe18b1a 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: intern.c 12910 2012-09-10 09:52:09Z doligez $ */ - /* Structured input, compact format */ /* The interface of this file is "intext.h" */ @@ -569,7 +567,7 @@ static void intern_add_to_heap(mlsize_t whsize) value caml_input_val(struct channel *chan) { uint32 magic; - mlsize_t block_len, num_objects, size_32, size_64, whsize; + mlsize_t block_len, num_objects, whsize; char * block; value res; @@ -579,8 +577,13 @@ value caml_input_val(struct channel *chan) if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); block_len = caml_getword(chan); num_objects = caml_getword(chan); - size_32 = caml_getword(chan); - size_64 = caml_getword(chan); +#ifdef ARCH_SIXTYFOUR + caml_getword(chan); /* skip size_32 */ + whsize = caml_getword(chan); +#else + whsize = caml_getword(chan); + caml_getword(chan); /* skip size_64 */ +#endif /* Read block from channel */ block = caml_stat_alloc(block_len); /* During [caml_really_getblock], concurrent [caml_input_val] operations @@ -594,12 +597,6 @@ value caml_input_val(struct channel *chan) intern_input = (unsigned char *) block; intern_input_malloced = 1; intern_src = intern_input; - /* Allocate result */ -#ifdef ARCH_SIXTYFOUR - whsize = size_64; -#else - whsize = size_32; -#endif intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&res); @@ -607,7 +604,7 @@ value caml_input_val(struct channel *chan) /* Free everything */ caml_stat_free(intern_input); if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); - return res; + return caml_check_urgent_gc(res); } CAMLprim value caml_input_value(value vchan) @@ -625,20 +622,20 @@ CAMLprim value caml_input_value(value vchan) CAMLexport value caml_input_val_from_string(value str, intnat ofs) { CAMLparam1 (str); - mlsize_t num_objects, size_32, size_64, whsize; + mlsize_t num_objects, whsize; CAMLlocal1 (obj); intern_src = &Byte_u(str, ofs + 2*4); intern_input_malloced = 0; num_objects = read32u(); - size_32 = read32u(); - size_64 = read32u(); - /* Allocate result */ #ifdef ARCH_SIXTYFOUR - whsize = size_64; + intern_src += 4; /* skip size_32 */ + whsize = read32u(); #else - whsize = size_32; + whsize = read32u(); + intern_src += 4; /* skip size_64 */ #endif + /* Allocate result */ intern_alloc(whsize, num_objects); intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ /* Fill it in */ @@ -646,7 +643,7 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs) intern_add_to_heap(whsize); /* Free everything */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); - CAMLreturn (obj); + CAMLreturn (caml_check_urgent_gc(obj)); } CAMLprim value caml_input_value_from_string(value str, value ofs) @@ -656,31 +653,30 @@ CAMLprim value caml_input_value_from_string(value str, value ofs) static value input_val_from_block(void) { - mlsize_t num_objects, size_32, size_64, whsize; + mlsize_t num_objects, whsize; value obj; num_objects = read32u(); - size_32 = read32u(); - size_64 = read32u(); - /* Allocate result */ #ifdef ARCH_SIXTYFOUR - whsize = size_64; + intern_src += 4; /* skip size_32 */ + whsize = read32u(); #else - whsize = size_32; + whsize = read32u(); + intern_src += 4; /* skip size_64 */ #endif + /* Allocate result */ intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&obj); intern_add_to_heap(whsize); /* Free internal data structures */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); - return obj; + return caml_check_urgent_gc(obj); } CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { uint32 magic; - mlsize_t block_len; value obj; intern_input = (unsigned char *) data; @@ -689,7 +685,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) magic = read32u(); if (magic != Intext_magic_number) caml_failwith("input_value_from_malloc: bad object"); - block_len = read32u(); + intern_src += 4; /* Skip block_len */ obj = input_val_from_block(); /* Free the input */ caml_stat_free(intern_input); @@ -755,7 +751,9 @@ static char * intern_resolve_code_pointer(unsigned char digest[16], static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X", + sprintf(msg, "input_value: unknown code module " + "%02X%02X%02X%02X%02X%02X%02X%02X" + "%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], digest[4], digest[5], digest[6], digest[7], digest[8], digest[9], digest[10], digest[11], diff --git a/byterun/interp.c b/byterun/interp.c index 6c602837..b99ed2f8 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: interp.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* The bytecode interpreter */ #include #include "alloc.h" @@ -113,7 +111,8 @@ sp is a local copy of the global variable caml_extern_sp. */ For GCC, I have hand-assigned hardware registers for several architectures. */ -#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) && !defined(__llvm__) +#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) \ + && !defined(__llvm__) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") @@ -217,7 +216,6 @@ value caml_interprete(code_t prog, asize_t prog_size) struct caml__roots_block * volatile initial_local_roots; volatile code_t saved_pc = NULL; struct longjmp_buffer raise_buf; - value * modify_dest, modify_newval; #ifndef THREADED_CODE opcode_t curr_instr; #endif @@ -707,29 +705,26 @@ value caml_interprete(code_t prog, asize_t prog_size) } Instruct(SETFIELD0): - modify_dest = &Field(accu, 0); - modify_newval = *sp++; - modify: - Modify(modify_dest, modify_newval); + caml_modify(&Field(accu, 0), *sp++); accu = Val_unit; Next; Instruct(SETFIELD1): - modify_dest = &Field(accu, 1); - modify_newval = *sp++; - goto modify; + caml_modify(&Field(accu, 1), *sp++); + accu = Val_unit; + Next; Instruct(SETFIELD2): - modify_dest = &Field(accu, 2); - modify_newval = *sp++; - goto modify; + caml_modify(&Field(accu, 2), *sp++); + accu = Val_unit; + Next; Instruct(SETFIELD3): - modify_dest = &Field(accu, 3); - modify_newval = *sp++; - goto modify; + caml_modify(&Field(accu, 3), *sp++); + accu = Val_unit; + Next; Instruct(SETFIELD): - modify_dest = &Field(accu, *pc); + caml_modify(&Field(accu, *pc), *sp++); + accu = Val_unit; pc++; - modify_newval = *sp++; - goto modify; + Next; Instruct(SETFLOATFIELD): Store_double_field(accu, *pc, Double_val(*sp)); accu = Val_unit; @@ -750,10 +745,10 @@ value caml_interprete(code_t prog, asize_t prog_size) sp += 1; Next; Instruct(SETVECTITEM): - modify_dest = &Field(accu, Long_val(sp[0])); - modify_newval = sp[1]; + caml_modify(&Field(accu, Long_val(sp[0])), sp[1]); + accu = Val_unit; sp += 2; - goto modify; + Next; /* String operations */ @@ -1123,7 +1118,7 @@ value caml_interprete(code_t prog, asize_t prog_size) #else caml_fatal_error_arg("Fatal error: bad opcode (%" ARCH_INTNAT_PRINTF_FORMAT "x)\n", - (char *)(*(pc-1))); + (char *) (intnat) *(pc-1)); #endif } } diff --git a/byterun/interp.h b/byterun/interp.h index a2a8237a..c8e2f89f 100644 --- a/byterun/interp.h +++ b/byterun/interp.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: interp.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* The bytecode interpreter */ #ifndef CAML_INTERP_H diff --git a/byterun/intext.h b/byterun/intext.h index 016792a7..f7aa655c 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: intext.h 12227 2012-03-13 14:44:48Z xleroy $ */ - /* Structured input/output */ #ifndef CAML_INTEXT_H diff --git a/byterun/ints.c b/byterun/ints.c index cc375d4b..4bf1d332 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: ints.c 12149 2012-02-10 16:15:24Z doligez $ */ - #include #include #include "alloc.h" @@ -116,6 +114,19 @@ intnat caml_safe_mod(intnat p, intnat q) } #endif +value caml_bswap16_direct(value x) +{ + return ((((x & 0x00FF) << 8) | + ((x & 0xFF00) >> 8))); +} + +CAMLprim value caml_bswap16(value v) +{ + intnat x = Int_val(v); + return (Val_int ((((x & 0x00FF) << 8) | + ((x & 0xFF00) >> 8)))); +} + /* Tagged integers */ CAMLprim value caml_int_compare(value v1, value v2) @@ -298,6 +309,20 @@ CAMLprim value caml_int32_shift_right(value v1, value v2) CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2) { return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } +static int32 caml_swap32(int32 x) +{ + return (((x & 0x000000FF) << 24) | + ((x & 0x0000FF00) << 8) | + ((x & 0x00FF0000) >> 8) | + ((x & 0xFF000000) >> 24)); +} + +value caml_int32_direct_bswap(value v) +{ return caml_swap32(v); } + +CAMLprim value caml_int32_bswap(value v) +{ return caml_copy_int32(caml_swap32(Int32_val(v))); } + CAMLprim value caml_int32_of_int(value v) { return caml_copy_int32(Long_val(v)); } @@ -488,6 +513,26 @@ CAMLprim value caml_int64_shift_right(value v1, value v2) CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) { return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } +#ifdef ARCH_SIXTYFOUR +static value caml_swap64(value x) +{ + return (((((x) & 0x00000000000000FF) << 56) | + (((x) & 0x000000000000FF00) << 40) | + (((x) & 0x0000000000FF0000) << 24) | + (((x) & 0x00000000FF000000) << 8) | + (((x) & 0x000000FF00000000) >> 8) | + (((x) & 0x0000FF0000000000) >> 24) | + (((x) & 0x00FF000000000000) >> 40) | + (((x) & 0xFF00000000000000) >> 56))); +} + +value caml_int64_direct_bswap(value v) +{ return caml_swap64(v); } +#endif + +CAMLprim value caml_int64_bswap(value v) +{ return caml_copy_int64(I64_bswap(Int64_val(v))); } + CAMLprim value caml_int64_of_int(value v) { return caml_copy_int64(I64_of_intnat(Long_val(v))); } @@ -714,7 +759,9 @@ CAMLprim value caml_nativeint_mod(value v1, value v2) if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ - if (dividend == Nativeint_min_int && divisor == -1) return caml_copy_nativeint(0); + if (dividend == Nativeint_min_int && divisor == -1){ + return caml_copy_nativeint(0); + } #ifdef NONSTANDARD_DIV_MOD return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); #else @@ -740,6 +787,24 @@ CAMLprim value caml_nativeint_shift_right(value v1, value v2) CAMLprim value caml_nativeint_shift_right_unsigned(value v1, value v2) { return caml_copy_nativeint((uintnat)Nativeint_val(v1) >> Int_val(v2)); } +value caml_nativeint_direct_bswap(value v) +{ +#ifdef ARCH_SIXTYFOUR + return caml_swap64(v); +#else + return caml_swap32(v); +#endif +} + +CAMLprim value caml_nativeint_bswap(value v) +{ +#ifdef ARCH_SIXTYFOUR + return caml_copy_nativeint(caml_swap64(Nativeint_val(v))); +#else + return caml_copy_nativeint(caml_swap32(Nativeint_val(v))); +#endif +} + CAMLprim value caml_nativeint_of_int(value v) { return caml_copy_nativeint(Long_val(v)); } diff --git a/byterun/io.c b/byterun/io.c index ca01a4fe..676cb5b2 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: io.c 12641 2012-06-25 12:02:16Z lefessan $ */ - /* Buffered input/output. */ #include diff --git a/byterun/io.h b/byterun/io.h index 6d2d2713..8420d159 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: io.h 12331 2012-04-10 14:07:40Z doligez $ */ - /* Buffered input/output */ #ifndef CAML_IO_H diff --git a/byterun/lexing.c b/byterun/lexing.c index dda5911e..8242cc7a 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: lexing.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* The table-driven automaton for lexers generated by camllex. */ #include "fail.h" @@ -220,7 +218,8 @@ CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state, else pc_off = Short(tbl->lex_default_code, pstate) ; if (pc_off > 0) - run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ; + run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, + lexbuf->lex_curr_pos) ; /* Erase the EOF condition only if the EOF pseudo-character was consumed by the automaton (i.e. there was no backtrack above) */ diff --git a/byterun/main.c b/byterun/main.c index 0689e630..b51c31c5 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: main.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ @@ -29,13 +27,13 @@ CAMLextern void caml_expand_command_line (int *, char ***); int main(int argc, char **argv) { #ifdef DEBUG + caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); +#if 0 { + int i; char *ocp; char *cp; - int i; - caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); -#if 0 caml_gc_message (-1, "### command line:", 0); for (i = 0; i < argc; i++){ caml_gc_message (-1, " %s", argv[i]); @@ -46,9 +44,9 @@ int main(int argc, char **argv) cp = getenv ("CAMLRUNPARAM"); caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp); caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0)); -#endif } #endif +#endif #ifdef _WIN32 /* Expand wildcards and diversions in command line */ caml_expand_command_line(&argc, &argv); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 99a92858..14a248f0 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c 12910 2012-09-10 09:52:09Z doligez $ */ - #include #include "compact.h" @@ -491,7 +489,8 @@ void caml_init_major_heap (asize_t heap_size) if (caml_page_table_add(In_heap, caml_heap_start, caml_heap_start + caml_stat_heap_size) != 0) { - caml_fatal_error ("Fatal error: not enough memory for the initial page table.\n"); + caml_fatal_error ("Fatal error: not enough memory " + "for the initial page table.\n"); } caml_fl_init_merge (); diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 95178e4b..f473df94 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_MAJOR_GC_H #define CAML_MAJOR_GC_H diff --git a/byterun/md5.c b/byterun/md5.c index 2e571272..10ac76ab 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: md5.c 12800 2012-07-30 18:59:07Z doligez $ */ - #include #include "alloc.h" #include "fail.h" @@ -215,7 +213,7 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); byteReverse((unsigned char *) ctx->buf, 4); memcpy(digest, ctx->buf, 16); - memset(ctx, 0, sizeof(ctx)); /* In case it's sensitive */ + memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */ } /* The four core functions - F1 is optimized somewhat */ diff --git a/byterun/md5.h b/byterun/md5.h index a041fab0..d8aff097 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: md5.h 12800 2012-07-30 18:59:07Z doligez $ */ - /* MD5 message digest */ #ifndef CAML_MD5_H diff --git a/byterun/memory.c b/byterun/memory.c index 82357802..54d91c96 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: memory.c 12910 2012-09-10 09:52:09Z doligez $ */ - #include #include #include "fail.h" @@ -502,12 +500,14 @@ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max) A block value [v] is a shared block if and only if [Is_in_heap (v)] is true. */ -/* [caml_initialize] never calls the GC, so you may call it while an block is +/* [caml_initialize] never calls the GC, so you may call it while a block is unfinished (i.e. just after a call to [caml_alloc_shr].) */ -void caml_initialize (value *fp, value val) +/* PR#6084 workaround: define it as a weak symbol */ +CAMLexport CAMLweakdef void caml_initialize (value *fp, value val) { + CAMLassert(Is_in_heap(fp)); *fp = val; - if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){ + if (Is_block (val) && Is_young (val)) { if (caml_ref_table.ptr >= caml_ref_table.limit){ caml_realloc_ref_table (&caml_ref_table); } @@ -519,9 +519,54 @@ void caml_initialize (value *fp, value val) unless you are sure the value being overwritten is not a shared block and the value being written is not a young block. */ /* [caml_modify] never calls the GC. */ -void caml_modify (value *fp, value val) +/* [caml_modify] can also be used to do assignment on data structures that are + in the minor heap instead of in the major heap. In this case, it + is a bit slower than simple assignment. + In particular, you can use [caml_modify] when you don't know whether the + block being changed is in the minor heap or the major heap. */ +/* PR#6084 workaround: define it as a weak symbol */ + +CAMLexport CAMLweakdef void caml_modify (value *fp, value val) { - Modify (fp, val); + /* The write barrier implemented by [caml_modify] checks for the + following two conditions and takes appropriate action: + 1- a pointer from the major heap to the minor heap is created + --> add [fp] to the remembered set + 2- a pointer from the major heap to the major heap is overwritten, + while the GC is in the marking phase + --> call [caml_darken] on the overwritten pointer so that the + major GC treats it as an additional root. + */ + value old; + + if (Is_young((value)fp)) { + /* The modified object resides in the minor heap. + Conditions 1 and 2 cannot occur. */ + *fp = val; + } else { + /* The modified object resides in the major heap. */ + CAMLassert(Is_in_heap(fp)); + old = *fp; + *fp = val; + if (Is_block(old)) { + /* If [old] is a pointer within the minor heap, we already + have a major->minor pointer and [fp] is already in the + remembered set. Conditions 1 and 2 cannot occur. */ + if (Is_young(old)) return; + /* Here, [old] can be a pointer within the major heap. + Check for condition 2. */ + if (caml_gc_phase == Phase_mark) caml_darken(old, NULL); + } + /* Check for condition 1. */ + if (Is_block(val) && Is_young(val)) { + /* Add [fp] to remembered set */ + if (caml_ref_table.ptr >= caml_ref_table.limit){ + CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); + caml_realloc_ref_table (&caml_ref_table); + } + *caml_ref_table.ptr++ = fp; + } + } } CAMLexport void * caml_stat_alloc (asize_t sz) diff --git a/byterun/memory.h b/byterun/memory.h index 56561968..07610701 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: memory.h 12210 2012-03-08 19:52:03Z doligez $ */ - /* Allocation macros and functions */ #ifndef CAML_MEMORY_H @@ -119,32 +117,9 @@ int caml_page_table_initialize(mlsize_t bytesize); DEBUG_clear ((result), (wosize)); \ }while(0) -/* You must use [Modify] to change a field of an existing shared block, - unless you are sure the value being overwritten is not a shared block and - the value being written is not a young block. */ -/* [Modify] never calls the GC. */ -/* [Modify] can also be used to do assignment on data structures that are - not in the (major) heap. In this case, it is a bit slower than - simple assignment. - In particular, you can use [Modify] when you don't know whether the - block being changed is in the minor heap or the major heap. -*/ +/* Deprecated alias for [caml_modify] */ -#define Modify(fp, val) do{ \ - value _old_ = *(fp); \ - *(fp) = (val); \ - if (Is_in_heap (fp)){ \ - if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL); \ - if (Is_block (val) && Is_young (val) \ - && ! (Is_block (_old_) && Is_young (_old_))){ \ - if (caml_ref_table.ptr >= caml_ref_table.limit){ \ - CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); \ - caml_realloc_ref_table (&caml_ref_table); \ - } \ - *caml_ref_table.ptr++ = (fp); \ - } \ - } \ -}while(0) +#define Modify(fp,val) caml_modify((fp), (val)) /* */ @@ -214,7 +189,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ CAMLxparamN (x, (size)) -#if defined (__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) +#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) #define CAMLunused __attribute__ ((unused)) #else #define CAMLunused diff --git a/byterun/meta.c b/byterun/meta.c index 2bb222ab..e5c6f941 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: meta.c 12253 2012-03-21 14:31:18Z xleroy $ */ - /* Primitives for the toplevel */ #include diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 474ce55f..b15d1e44 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.c 12194 2012-03-06 19:17:29Z doligez $ */ - #include #include "config.h" #include "fail.h" @@ -73,13 +71,14 @@ static void clear_table (struct caml_ref_table *tbl) tbl->limit = tbl->threshold; } +/* size in bytes */ void caml_set_minor_heap_size (asize_t size) { char *new_heap; void *new_heap_base; - Assert (size >= Minor_heap_min); - Assert (size <= Minor_heap_max); + Assert (size >= Bsize_wsize(Minor_heap_min)); + Assert (size <= Bsize_wsize(Minor_heap_max)); Assert (size % sizeof (value) == 0); if (caml_young_ptr != caml_young_end) caml_minor_collection (); Assert (caml_young_ptr == caml_young_end); diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 892929ab..4727826d 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_MINOR_GC_H #define CAML_MINOR_GC_H @@ -39,7 +37,7 @@ CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; (Assert (Is_block (val)), \ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) -extern void caml_set_minor_heap_size (asize_t); +extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ diff --git a/byterun/misc.c b/byterun/misc.c index 5914f38f..6eeae0f1 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: misc.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include "config.h" #include "misc.h" diff --git a/byterun/misc.h b/byterun/misc.h index f8bfda6a..4fd82af2 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: misc.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Miscellaneous macros and variables. */ #ifndef CAML_MISC_H @@ -53,12 +51,21 @@ typedef char * addr; #define CAMLprim #define CAMLextern extern +/* Weak function definitions that can be overriden by external libs */ +/* Conservatively restricted to ELF and MacOSX platforms */ +#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) +#define CAMLweakdef __attribute__((weak)) +#else +#define CAMLweakdef +#endif + /* Assertions */ /* */ #ifdef DEBUG -#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) +#define CAMLassert(x) \ + ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) CAMLextern int caml_failed_assert (char *, char *, int); #else #define CAMLassert(x) ((void) 0) diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 02666279..cbb1c7bf 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: mlvalues.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_MLVALUES_H #define CAML_MLVALUES_H diff --git a/byterun/obj.c b/byterun/obj.c index ac784a34..8e00282e 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: obj.c 12149 2012-02-10 16:15:24Z doligez $ */ - /* Operations on objects */ #include diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 6beebc02..8123d49b 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: osdeps.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Operating system - specific stuff */ #ifndef CAML_OSDEPS_H diff --git a/byterun/parsing.c b/byterun/parsing.c index 0cde1df1..3c1ced7d 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: parsing.c 11927 2011-12-21 16:31:01Z xleroy $ */ - /* The PDA automaton for parsers generated by camlyacc */ #include diff --git a/byterun/prims.h b/byterun/prims.h index b65da503..7a996781 100644 --- a/byterun/prims.h +++ b/byterun/prims.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: prims.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Interface with C primitives. */ #ifndef CAML_PRIMS_H diff --git a/byterun/printexc.c b/byterun/printexc.c index f88ecef1..7e3259ab 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: printexc.c 11927 2011-12-21 16:31:01Z xleroy $ */ - /* Print an uncaught exception and abort */ #include diff --git a/byterun/printexc.h b/byterun/printexc.h index 025e0322..748faa9c 100644 --- a/byterun/printexc.h +++ b/byterun/printexc.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: printexc.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_PRINTEXC_H #define CAML_PRINTEXC_H diff --git a/byterun/reverse.h b/byterun/reverse.h index e73dd7e6..09d34a51 100644 --- a/byterun/reverse.h +++ b/byterun/reverse.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: reverse.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Swap byte-order in 16, 32, and 64-bit integers or floats */ #ifndef CAML_REVERSE_H diff --git a/byterun/roots.c b/byterun/roots.c index 679ddba9..43afbedc 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: roots.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* To walk the memory roots for garbage collection */ #include "finalise.h" diff --git a/byterun/roots.h b/byterun/roots.h index 054b979c..ca6a5d26 100644 --- a/byterun/roots.h +++ b/byterun/roots.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: roots.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_ROOTS_H #define CAML_ROOTS_H diff --git a/byterun/signals.c b/byterun/signals.c index ddc0f222..10f452b4 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -11,11 +11,10 @@ /* */ /***********************************************************************/ -/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Signal handling, code common to the bytecode and native systems */ #include +#include #include "alloc.h" #include "callback.h" #include "config.h" @@ -117,8 +116,12 @@ CAMLexport void caml_enter_blocking_section(void) CAMLexport void caml_leave_blocking_section(void) { + int saved_errno; + /* Save the value of errno (PR#5982). */ + saved_errno = errno; caml_leave_blocking_section_hook (); caml_process_pending_signals(); + errno = saved_errno; } /* Execute a signal handler immediately */ diff --git a/byterun/signals.h b/byterun/signals.h index 1df392ca..58451666 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: signals.h 12000 2012-01-07 20:55:28Z lefessan $ */ - #ifndef CAML_SIGNALS_H #define CAML_SIGNALS_H diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c index 6e4d7f3f..9703afaa 100644 --- a/byterun/signals_byt.c +++ b/byterun/signals_byt.c @@ -11,11 +11,10 @@ /* */ /***********************************************************************/ -/* $Id: signals_byt.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Signal handling, code specific to the bytecode interpreter */ #include +#include #include "config.h" #include "memory.h" #include "osdeps.h" @@ -51,6 +50,9 @@ void caml_process_event(void) static void handle_signal(int signal_number) { + int saved_errno; + /* Save the value of errno (PR#5982). */ + saved_errno = errno; #if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) signal(signal_number, handle_signal); #endif @@ -60,7 +62,8 @@ static void handle_signal(int signal_number) caml_enter_blocking_section_hook(); }else{ caml_record_signal(signal_number); - } + } + errno = saved_errno; } int caml_set_signal_action(int signo, int action) diff --git a/byterun/signals_machdep.h b/byterun/signals_machdep.h index b8e9ff52..4987e2f6 100644 --- a/byterun/signals_machdep.h +++ b/byterun/signals_machdep.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: signals_machdep.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Processor-specific operation: atomic "read and clear" */ #ifndef CAML_SIGNALS_MACHDEP_H diff --git a/byterun/stacks.c b/byterun/stacks.c index 4fdb463a..bc2bdc46 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: stacks.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* To initialize and resize the stacks */ #include diff --git a/byterun/stacks.h b/byterun/stacks.h index 73f08d29..c596f255 100644 --- a/byterun/stacks.h +++ b/byterun/stacks.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: stacks.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* structure of the stacks */ #ifndef CAML_STACKS_H diff --git a/byterun/startup.c b/byterun/startup.c index b774016d..7b9aad46 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: startup.c 12715 2012-07-16 10:37:03Z frisch $ */ - /* Start-up code */ #include @@ -75,7 +73,7 @@ static void init_atoms(void) for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); if (caml_page_table_add(In_static_data, caml_atom_table, caml_atom_table + 256) != 0) { - caml_fatal_error("Fatal error: not enough memory for the initial page table"); + caml_fatal_error("Fatal error: not enough memory for initial page table"); } } @@ -90,7 +88,8 @@ static void fixup_endianness_trailer(uint32 * p) static int read_trailer(int fd, struct exec_trailer *trail) { - lseek(fd, (long) -TRAILER_SIZE, SEEK_END); + if (lseek(fd, (long) -TRAILER_SIZE, SEEK_END) == -1) + return BAD_BYTECODE; if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE) return BAD_BYTECODE; fixup_endianness_trailer(&trail->num_sections); @@ -309,16 +308,20 @@ static void parse_camlrunparam(void) if (opt != NULL){ while (*opt != '\0'){ switch (*opt++){ - case 's': scanmult (opt, &minor_heap_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; + case 'b': caml_record_backtrace(Val_true); break; case 'h': scanmult (opt, &heap_size_init); break; + case 'i': scanmult (opt, &heap_chunk_init); break; case 'l': scanmult (opt, &max_stack_init); break; case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; - case 'v': scanmult (opt, &caml_verb_gc); break; - case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; - case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; + /* case 'R': see stdlib/hashtbl.mli */ + case 's': scanmult (opt, &minor_heap_init); break; +#ifdef DEBUG + case 't': caml_trace_flag = 1; break; +#endif + case 'v': scanmult (opt, &caml_verb_gc); break; } } } @@ -330,6 +333,13 @@ extern void caml_init_ieee_floats (void); extern void caml_signal_thread(void * lpParam); #endif +#ifdef _MSC_VER + +/* PR 4887: avoid crash box of windows runtime on some system calls */ +extern void caml_install_invalid_parameter_handler(); + +#endif + /* Main entry point when loading code from a file */ CAMLexport void caml_main(char **argv) @@ -347,6 +357,9 @@ CAMLexport void caml_main(char **argv) /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ caml_init_ieee_floats(); +#ifdef _MSC_VER + caml_install_invalid_parameter_handler(); +#endif caml_init_custom_operations(); caml_ext_table_init(&caml_shared_libs_path, 8); caml_external_raise = NULL; @@ -449,6 +462,9 @@ CAMLexport void caml_startup_code( #endif caml_init_ieee_floats(); +#ifdef _MSC_VER + caml_install_invalid_parameter_handler(); +#endif caml_init_custom_operations(); #ifdef DEBUG caml_verb_gc = 63; diff --git a/byterun/startup.h b/byterun/startup.h index d0409cec..3dda64b3 100644 --- a/byterun/startup.h +++ b/byterun/startup.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: startup.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_STARTUP_H #define CAML_STARTUP_H diff --git a/byterun/str.c b/byterun/str.c index 7daea00f..9a96147e 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: str.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Operations on strings */ #include @@ -65,6 +63,154 @@ CAMLprim value caml_string_set(value str, value index, value newval) return Val_unit; } +CAMLprim value caml_string_get16(value str, value index) +{ + intnat res; + unsigned char b1, b2; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + b1 = Byte_u(str, idx); + b2 = Byte_u(str, idx + 1); +#ifdef ARCH_BIG_ENDIAN + res = b1 << 8 | b2; +#else + res = b2 << 8 | b1; +#endif + return Val_int(res); +} + +CAMLprim value caml_string_get32(value str, value index) +{ + intnat res; + unsigned char b1, b2, b3, b4; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + b1 = Byte_u(str, idx); + b2 = Byte_u(str, idx + 1); + b3 = Byte_u(str, idx + 2); + b4 = Byte_u(str, idx + 3); +#ifdef ARCH_BIG_ENDIAN + res = b1 << 24 | b2 << 16 | b3 << 8 | b4; +#else + res = b4 << 24 | b3 << 16 | b2 << 8 | b1; +#endif + return caml_copy_int32(res); +} + +#ifdef ARCH_INT64_TYPE +#include "int64_native.h" +#else +#include "int64_emul.h" +#endif + +CAMLprim value caml_string_get64(value str, value index) +{ + uint32 reshi; + uint32 reslo; + unsigned char b1, b2, b3, b4, b5, b6, b7, b8; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + b1 = Byte_u(str, idx); + b2 = Byte_u(str, idx + 1); + b3 = Byte_u(str, idx + 2); + b4 = Byte_u(str, idx + 3); + b5 = Byte_u(str, idx + 4); + b6 = Byte_u(str, idx + 5); + b7 = Byte_u(str, idx + 6); + b8 = Byte_u(str, idx + 7); +#ifdef ARCH_BIG_ENDIAN + reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; + reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; +#else + reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; + reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; +#endif + return caml_copy_int64(I64_literal(reshi,reslo)); +} + +CAMLprim value caml_string_set16(value str, value index, value newval) +{ + unsigned char b1, b2; + intnat val; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + val = Long_val(newval); +#ifdef ARCH_BIG_ENDIAN + b1 = 0xFF & val >> 8; + b2 = 0xFF & val; +#else + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; +#endif + Byte_u(str, idx) = b1; + Byte_u(str, idx + 1) = b2; + return Val_unit; +} + +CAMLprim value caml_string_set32(value str, value index, value newval) +{ + unsigned char b1, b2, b3, b4; + intnat val; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + val = Int32_val(newval); +#ifdef ARCH_BIG_ENDIAN + b1 = 0xFF & val >> 24; + b2 = 0xFF & val >> 16; + b3 = 0xFF & val >> 8; + b4 = 0xFF & val; +#else + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; +#endif + Byte_u(str, idx) = b1; + Byte_u(str, idx + 1) = b2; + Byte_u(str, idx + 2) = b3; + Byte_u(str, idx + 3) = b4; + return Val_unit; +} + +CAMLprim value caml_string_set64(value str, value index, value newval) +{ + unsigned char b1, b2, b3, b4, b5, b6, b7, b8; + uint32 lo,hi; + int64 val; + intnat idx = Long_val(index); + if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + val = Int64_val(newval); + I64_split(val,hi,lo); +#ifdef ARCH_BIG_ENDIAN + b1 = 0xFF & hi >> 24; + b2 = 0xFF & hi >> 16; + b3 = 0xFF & hi >> 8; + b4 = 0xFF & hi; + b5 = 0xFF & lo >> 24; + b6 = 0xFF & lo >> 16; + b7 = 0xFF & lo >> 8; + b8 = 0xFF & lo; +#else + b8 = 0xFF & hi >> 24; + b7 = 0xFF & hi >> 16; + b6 = 0xFF & hi >> 8; + b5 = 0xFF & hi; + b4 = 0xFF & lo >> 24; + b3 = 0xFF & lo >> 16; + b2 = 0xFF & lo >> 8; + b1 = 0xFF & lo; +#endif + Byte_u(str, idx) = b1; + Byte_u(str, idx + 1) = b2; + Byte_u(str, idx + 2) = b3; + Byte_u(str, idx + 3) = b4; + Byte_u(str, idx + 4) = b5; + Byte_u(str, idx + 5) = b6; + Byte_u(str, idx + 6) = b7; + Byte_u(str, idx + 7) = b8; + return Val_unit; +} + CAMLprim value caml_string_equal(value s1, value s2) { mlsize_t sz1, sz2; diff --git a/byterun/sys.c b/byterun/sys.c index 7a4338c2..332887b1 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: sys.c 12242 2012-03-14 15:27:58Z xleroy $ */ - /* Basic system calls */ #include @@ -336,6 +334,35 @@ CAMLprim value caml_sys_random_seed (value unit) return res; } +CAMLprim value caml_sys_const_big_endian(value unit) +{ +#ifdef ARCH_BIG_ENDIAN + return Val_true; +#else + return Val_false; +#endif +} + +CAMLprim value caml_sys_const_word_size(value unit) +{ + return Val_long(8 * sizeof(value)); +} + +CAMLprim value caml_sys_const_ostype_unix(value unit) +{ + return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix")); +} + +CAMLprim value caml_sys_const_ostype_win32(value unit) +{ + return Val_long(0 == strcmp(OCAML_OS_TYPE,"Win32")); +} + +CAMLprim value caml_sys_const_ostype_cygwin(value unit) +{ + return Val_long(0 == strcmp(OCAML_OS_TYPE,"Cygwin")); +} + CAMLprim value caml_sys_get_config(value unit) { CAMLparam0 (); /* unit is unused */ diff --git a/byterun/sys.h b/byterun/sys.h index ada59cc7..5eb18fc0 100644 --- a/byterun/sys.h +++ b/byterun/sys.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: sys.h 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef CAML_SYS_H #define CAML_SYS_H diff --git a/byterun/terminfo.c b/byterun/terminfo.c index f537b3e7..04086a3f 100644 --- a/byterun/terminfo.c +++ b/byterun/terminfo.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: terminfo.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Read and output terminal commands */ #include "config.h" diff --git a/byterun/ui.h b/byterun/ui.h index 2077d3bc..29584650 100644 --- a/byterun/ui.h +++ b/byterun/ui.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: ui.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Function declarations for non-Unix user interfaces */ #ifndef CAML_UI_H diff --git a/byterun/unix.c b/byterun/unix.c index 7d24ef4b..3fee9a39 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: unix.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Unix-specific stuff */ #define _GNU_SOURCE @@ -213,7 +211,8 @@ char * caml_dlerror(void) 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) + | RTLD_NODELETE); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } diff --git a/byterun/weak.c b/byterun/weak.c index 2b63455e..75699671 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: weak.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Operations on weak arrays */ #include diff --git a/byterun/weak.h b/byterun/weak.h index 4defaf54..0cf4b8b2 100644 --- a/byterun/weak.h +++ b/byterun/weak.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: weak.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Operations on weak arrays */ #ifndef CAML_WEAK_H diff --git a/byterun/win32.c b/byterun/win32.c index f8ba9c98..d807f690 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: win32.c 12686 2012-07-10 11:34:39Z scherer $ */ - /* Win32-specific stuff */ #include @@ -33,7 +31,7 @@ #include "signals.h" #include "sys.h" -#include "flexdll.h" +#include #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) @@ -93,7 +91,7 @@ CAMLexport char * caml_search_exe_in_path(char * name) pathlen = strlen(name) + 1; if (pathlen < 256) pathlen = 256; while (1) { - fullname = stat_alloc(pathlen); + fullname = caml_stat_alloc(pathlen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ @@ -107,7 +105,7 @@ CAMLexport char * caml_search_exe_in_path(char * name) break; } if (retcode < pathlen) break; - stat_free(fullname); + caml_stat_free(fullname); pathlen = retcode + 1; } return fullname; @@ -471,11 +469,36 @@ int caml_win32_random_seed (intnat data[16]) { /* For better randomness, consider: http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp + http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx */ FILETIME t; + LARGE_INTEGER pc; GetSystemTimeAsFileTime(&t); + QueryPerformanceCounter(&pc); /* PR#6032 */ data[0] = t.dwLowDateTime; data[1] = t.dwHighDateTime; data[2] = GetCurrentProcessId(); - return 3; + data[3] = pc.LowPart; + data[4] = pc.HighPart; + return 5; +} + + +#ifdef _MSC_VER + +static void invalid_parameter_handler(const wchar_t* expression, + const wchar_t* function, + const wchar_t* file, + unsigned int line, + uintptr_t pReserved) +{ + /* no crash box */ } + + +void caml_install_invalid_parameter_handler() +{ + _set_invalid_parameter_handler(invalid_parameter_handler); +} + +#endif diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index c9e94154..3c04214a 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -352,8 +352,11 @@ module Make (Ast : Sig.Camlp4Ast) = struct fun [ <:ctyp< $t1$ == $t2$ >> -> type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | <:ctyp< private $t$ >> -> - type_decl tl cl loc m True t + | <:ctyp@_loc< private $t$ >> -> + if pflag then + error _loc "multiple private keyword used, use only one instead" + else + type_decl tl cl loc m True t | <:ctyp< { $t$ } >> -> mktype loc tl cl (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m @@ -861,7 +864,7 @@ value varify_constructors var_names = let e2 = ExSeq loc el in mkexp loc (Pexp_while (expr e1) (expr e2)) | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open (long_uident i) (expr e)) + mkexp loc (Pexp_open Fresh (long_uident i) (expr e)) | <:expr@loc< (module $me$ : $pt$) >> -> mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), Some (mktyp loc (Ptyp_package (package_type pt))), None)) @@ -1005,7 +1008,7 @@ value varify_constructors var_names = in [mksig loc (Psig_modtype (with_loc n loc) si) :: l] | SgOpn loc id -> - [mksig loc (Psig_open (long_uident id)) :: l] + [mksig loc (Psig_open Fresh (long_uident id)) :: l] | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] @@ -1060,7 +1063,7 @@ value varify_constructors var_names = [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) (List.map ctyp (list_of_ctyp t []))) :: l ] | <:str_item@loc< exception $uid:s$ = $i$ >> -> - [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (ident i)) :: l ] + [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (long_uident ~conv_con i)) :: l ] | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> error loc "type in exception alias" | StExc _ _ _ -> assert False (*FIXME*) @@ -1072,7 +1075,7 @@ value varify_constructors var_names = [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] | StOpn loc id -> - [mkstr loc (Pstr_open (long_uident id)) :: l] + [mkstr loc (Pstr_open Fresh (long_uident id)) :: l] | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] | StVal loc rf bi -> [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml index d8f9f9aa..4273ebeb 100644 --- a/camlp4/Camlp4/Struct/Grammar/Delete.ml +++ b/camlp4/Camlp4/Struct/Grammar/Delete.ml @@ -17,11 +17,37 @@ * - Nicolas Pouillard: refactoring *) +exception Rule_not_found of (string * string); + +let () = + Printexc.register_printer + (fun + [ Rule_not_found (symbols, entry) -> + let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in + Some msg + | _ -> None ]) in () +; + module Make (Structure : Structure.S) = struct module Tools = Tools.Make Structure; module Parser = Parser.Make Structure; + module Print = Print.Make Structure; open Structure; +value raise_rule_not_found entry symbols = + let to_string f x = + let buff = Buffer.create 128 in + let ppf = Format.formatter_of_buffer buff in + do { + f ppf x; + Format.pp_print_flush ppf (); + Buffer.contents buff + } in + let entry = to_string Print.entry entry in + let symbols = to_string Print.print_rule symbols in + raise (Rule_not_found (symbols, entry)) +; + (* Deleting a rule *) (* [delete_rule_in_tree] returns @@ -104,7 +130,7 @@ value rec delete_rule_in_suffix entry symbols = | None -> let levs = delete_rule_in_suffix entry symbols levs in [lev :: levs] ] - | [] -> raise Not_found ] + | [] -> raise_rule_not_found entry symbols ] ; value rec delete_rule_in_prefix entry symbols = @@ -128,7 +154,7 @@ value rec delete_rule_in_prefix entry symbols = | None -> let levs = delete_rule_in_prefix entry symbols levs in [lev :: levs] ] - | [] -> raise Not_found ] + | [] -> raise_rule_not_found entry symbols ] ; value rec delete_rule_in_level_list entry symbols levs = diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml index 7bdad3c4..f2216610 100644 --- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -102,7 +102,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct try do { DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END; True - } with [ Not_found -> False ]; + } with [ Struct.Grammar.Delete.Rule_not_found _ -> False ]; value comprehension_or_sem_expr_for_list = Gram.Entry.mk "comprehension_or_sem_expr_for_list"; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 4a2f8d90..d32fad9b 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -190,7 +190,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct clear package_type; clear top_phrase; - EXTEND Gram + let apply () = EXTEND Gram GLOBAL: a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident @@ -706,7 +706,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | `EOI -> None ] ] ; - END; + END in apply (); (* Some other DELETE_RULE are before the grammar *) DELETE_RULE Gram module_longident_with_app: "("; SELF; ")" END; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml index 02c89f81..85efa827 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml @@ -40,7 +40,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct value revised = try (DELETE_RULE Gram expr: "if"; SELF; "then"; SELF; "else"; SELF END; True) - with [ Not_found -> begin + with [ Struct.Grammar.Delete.Rule_not_found _ -> begin DELETE_RULE Gram expr: "if"; SELF; "then"; expr LEVEL "top"; "else"; expr LEVEL "top" END; DELETE_RULE Gram expr: "if"; SELF; "then"; expr LEVEL "top" END; False end ]; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index 328e00f9..ffca6798 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -400,7 +400,7 @@ New syntax:\ parser [: a = symb; s :] -> kont a s end; - EXTEND Gram + let apply () = EXTEND Gram GLOBAL: a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT rec_binding_quot a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident @@ -1918,7 +1918,7 @@ New syntax:\ expr_eoi: [ [ x = expr; `EOI -> x ] ] ; - END; + END in apply (); end; diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 9e8309b6..2a6a4fbf 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -14522,7 +14522,12 @@ module Struct = function | Ast.TyMan (_, t1, t2) -> type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t + | Ast.TyPrv (_loc, t) -> + if pflag + then + error _loc + "multiple private keyword used, use only one instead" + else type_decl tl cl loc m true t | Ast.TyRec (_, t) -> mktype loc tl cl (Ptype_record (List.map mktrecord (list_of_ctyp t []))) @@ -15167,7 +15172,7 @@ module Struct = let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while ((expr e1), (expr e2))) | Ast.ExOpI (loc, i, e) -> - mkexp loc (Pexp_open ((long_uident i), (expr e))) + mkexp loc (Pexp_open (Fresh, (long_uident i), (expr e))) | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> mkexp loc (Pexp_constraint @@ -15347,7 +15352,7 @@ module Struct = | _ -> Pmodtype_manifest (module_type mt)) in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l | SgOpn (loc, id) -> - (mksig loc (Psig_open (long_uident id))) :: l + (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l | SgTyp (loc, tdl) -> (mksig loc (Psig_type (mktype_decl tdl []))) :: l | SgVal (loc, n, t) -> @@ -15431,7 +15436,7 @@ module Struct = (Ast.OSome i)) -> (mkstr loc (Pstr_exn_rebind ((with_loc (conv_con s) loc), - (ident i)))) :: + (long_uident ~conv_con i)))) :: l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), @@ -15457,7 +15462,7 @@ module Struct = (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: l | StOpn (loc, id) -> - (mkstr loc (Pstr_open (long_uident id))) :: l + (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l | StTyp (loc, tdl) -> (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l | StVal (loc, rf, bi) -> @@ -17974,14 +17979,43 @@ module Struct = module Delete = struct + exception Rule_not_found of (string * string) + + let _ = + let () = + Printexc.register_printer + (function + | Rule_not_found ((symbols, entry)) -> + let msg = + Printf.sprintf + "rule %S cannot be found in entry\n%s" symbols + entry + in Some msg + | _ -> None) + in () + module Make (Structure : Structure.S) = struct module Tools = Tools.Make(Structure) module Parser = Parser.Make(Structure) + module Print = Print.Make(Structure) + open Structure + let raise_rule_not_found entry symbols = + let to_string f x = + let buff = Buffer.create 128 in + let ppf = Format.formatter_of_buffer buff + in + (f ppf x; + Format.pp_print_flush ppf (); + Buffer.contents buff) in + let entry = to_string Print.entry entry in + let symbols = to_string Print.print_rule symbols + in raise (Rule_not_found ((symbols, entry))) + let delete_rule_in_tree entry = let rec delete_in_tree symbols tree = match (symbols, tree) with @@ -18080,7 +18114,7 @@ module Struct = let levs = delete_rule_in_suffix entry symbols levs in lev :: levs) - | [] -> raise Not_found + | [] -> raise_rule_not_found entry symbols let rec delete_rule_in_prefix entry symbols = function @@ -18107,7 +18141,7 @@ module Struct = let levs = delete_rule_in_prefix entry symbols levs in lev :: levs) - | [] -> raise Not_found + | [] -> raise_rule_not_found entry symbols let rec delete_rule_in_level_list entry symbols levs = match symbols with diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index 9f7a6d7b..fff2a1f3 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -741,8669 +741,8918 @@ New syntax:\ let a = symb __strm in kont a __strm) let _ = - let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) - and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t) - and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t) - and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - and _ = (package_type : 'package_type Gram.Entry.t) - and _ = (do_sequence : 'do_sequence Gram.Entry.t) - and _ = (infixop4 : 'infixop4 Gram.Entry.t) - and _ = (infixop3 : 'infixop3 Gram.Entry.t) - and _ = (infixop2 : 'infixop2 Gram.Entry.t) - and _ = (infixop1 : 'infixop1 Gram.Entry.t) - and _ = (infixop0 : 'infixop0 Gram.Entry.t) - and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) - and _ = (with_constr : 'with_constr Gram.Entry.t) - and _ = (value_val : 'value_val Gram.Entry.t) - and _ = (value_let : 'value_let Gram.Entry.t) - and _ = (val_longident : 'val_longident Gram.Entry.t) - and _ = (use_file : 'use_file Gram.Entry.t) - and _ = (typevars : 'typevars Gram.Entry.t) - and _ = (type_parameters : 'type_parameters Gram.Entry.t) - and _ = (type_parameter : 'type_parameter Gram.Entry.t) - and _ = - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - and _ = (type_longident : 'type_longident Gram.Entry.t) - and _ = (type_kind : 'type_kind Gram.Entry.t) - and _ = - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - and _ = (type_declaration : 'type_declaration Gram.Entry.t) - and _ = (type_constraint : 'type_constraint Gram.Entry.t) - and _ = (top_phrase : 'top_phrase Gram.Entry.t) - and _ = (str_items : 'str_items Gram.Entry.t) - and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) - and _ = (str_item : 'str_item Gram.Entry.t) - and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) - and _ = (sig_items : 'sig_items Gram.Entry.t) - and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) - and _ = (sig_item : 'sig_item Gram.Entry.t) - and _ = (sequence : 'sequence Gram.Entry.t) - and _ = (semi : 'semi Gram.Entry.t) - and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - and _ = (sem_patt : 'sem_patt Gram.Entry.t) - and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - and _ = (sem_expr : 'sem_expr Gram.Entry.t) - and _ = (row_field : 'row_field Gram.Entry.t) - and _ = (poly_type : 'poly_type Gram.Entry.t) - and _ = (phrase : 'phrase Gram.Entry.t) - and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) - and _ = (patt_quot : 'patt_quot Gram.Entry.t) - and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) - and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - and _ = (patt : 'patt Gram.Entry.t) - and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) - and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) - and _ = (opt_rec : 'opt_rec Gram.Entry.t) - and _ = (opt_private : 'opt_private Gram.Entry.t) - and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) - and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) - and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) - and _ = (opt_expr : 'opt_expr Gram.Entry.t) - and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) - and _ = (name_tags : 'name_tags Gram.Entry.t) - and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) - and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) - and _ = (module_type : 'module_type Gram.Entry.t) - and _ = - (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) - and _ = - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - and _ = (module_longident : 'module_longident Gram.Entry.t) - and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) - and _ = (module_expr : 'module_expr Gram.Entry.t) - and _ = (module_declaration : 'module_declaration Gram.Entry.t) - and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) - and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) - and _ = (module_binding : 'module_binding Gram.Entry.t) - and _ = (meth_decl : 'meth_decl Gram.Entry.t) - and _ = (meth_list : 'meth_list Gram.Entry.t) - and _ = (let_binding : 'let_binding Gram.Entry.t) - and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - and _ = (label_patt_list : 'label_patt_list Gram.Entry.t) - and _ = (label_patt : 'label_patt Gram.Entry.t) - and _ = (label_longident : 'label_longident Gram.Entry.t) - and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) - and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) - and _ = (label_expr : 'label_expr Gram.Entry.t) - and _ = - (label_declaration_list : 'label_declaration_list Gram.Entry.t) - and _ = (label_declaration : 'label_declaration Gram.Entry.t) - and _ = (label : 'label Gram.Entry.t) - and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - and _ = (ipatt : 'ipatt Gram.Entry.t) - and _ = (interf : 'interf Gram.Entry.t) - and _ = (implem : 'implem Gram.Entry.t) - and _ = (ident_quot : 'ident_quot Gram.Entry.t) - and _ = (ident : 'ident Gram.Entry.t) - and _ = (fun_def : 'fun_def Gram.Entry.t) - and _ = (fun_binding : 'fun_binding Gram.Entry.t) - and _ = (field_expr_list : 'field_expr_list Gram.Entry.t) - and _ = (field_expr : 'field_expr Gram.Entry.t) - and _ = (expr_quot : 'expr_quot Gram.Entry.t) - and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) - and _ = (expr : 'expr Gram.Entry.t) - and _ = (eq_expr : 'eq_expr Gram.Entry.t) - and _ = (dummy : 'dummy Gram.Entry.t) - and _ = (direction_flag : 'direction_flag Gram.Entry.t) - and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) - and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) - and _ = (ctyp : 'ctyp Gram.Entry.t) - and _ = - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - and _ = - (constructor_declaration : 'constructor_declaration Gram.Entry.t) - and _ = (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - and _ = (constrain : 'constrain Gram.Entry.t) - and _ = (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - and _ = (comma_patt : 'comma_patt Gram.Entry.t) - and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) - and _ = (comma_expr : 'comma_expr Gram.Entry.t) - and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) - and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) - and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) - and _ = - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - and _ = (class_type_longident : 'class_type_longident Gram.Entry.t) - and _ = - (class_type_declaration : 'class_type_declaration Gram.Entry.t) - and _ = (class_type : 'class_type Gram.Entry.t) - and _ = (class_structure : 'class_structure Gram.Entry.t) - and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - and _ = (class_str_item : 'class_str_item Gram.Entry.t) - and _ = (class_signature : 'class_signature Gram.Entry.t) - and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) - and _ = (class_name_and_param : 'class_name_and_param Gram.Entry.t) - and _ = - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - and _ = (class_longident : 'class_longident Gram.Entry.t) - and _ = - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - and _ = - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) - and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) - and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) - and _ = (class_expr : 'class_expr Gram.Entry.t) - and _ = (class_description : 'class_description Gram.Entry.t) - and _ = (class_declaration : 'class_declaration Gram.Entry.t) - and _ = (binding_quot : 'binding_quot Gram.Entry.t) - and _ = (binding : 'binding Gram.Entry.t) - and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) - and _ = (match_case0 : 'match_case0 Gram.Entry.t) - and _ = (match_case : 'match_case Gram.Entry.t) - and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) - and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) - and _ = (a_ident : 'a_ident Gram.Entry.t) - and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) - and _ = (a_STRING : 'a_STRING Gram.Entry.t) - and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) - and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) - and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) - and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) - and _ = (a_INT : 'a_INT Gram.Entry.t) - and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *) - (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t = - grammar_entry_create "infixop5" - and (* | i = opt_label; "("; p = patt_tcon; ")" -> *) - (* <:patt< ? $i$ : ($p$) >> *) - (* | i = opt_label; "("; p = ipatt_tcon; ")" -> + let apply () = + let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) + and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t) + and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) + and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) + and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t) + and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) + and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) + and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) + and _ = (package_type : 'package_type Gram.Entry.t) + and _ = (do_sequence : 'do_sequence Gram.Entry.t) + and _ = (infixop4 : 'infixop4 Gram.Entry.t) + and _ = (infixop3 : 'infixop3 Gram.Entry.t) + and _ = (infixop2 : 'infixop2 Gram.Entry.t) + and _ = (infixop1 : 'infixop1 Gram.Entry.t) + and _ = (infixop0 : 'infixop0 Gram.Entry.t) + and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) + and _ = (with_constr : 'with_constr Gram.Entry.t) + and _ = (value_val : 'value_val Gram.Entry.t) + and _ = (value_let : 'value_let Gram.Entry.t) + and _ = (val_longident : 'val_longident Gram.Entry.t) + and _ = (use_file : 'use_file Gram.Entry.t) + and _ = (typevars : 'typevars Gram.Entry.t) + and _ = (type_parameters : 'type_parameters Gram.Entry.t) + and _ = (type_parameter : 'type_parameter Gram.Entry.t) + and _ = + (type_longident_and_parameters : + 'type_longident_and_parameters Gram.Entry.t) + and _ = (type_longident : 'type_longident Gram.Entry.t) + and _ = (type_kind : 'type_kind Gram.Entry.t) + and _ = + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t) + and _ = (type_declaration : 'type_declaration Gram.Entry.t) + and _ = (type_constraint : 'type_constraint Gram.Entry.t) + and _ = (top_phrase : 'top_phrase Gram.Entry.t) + and _ = (str_items : 'str_items Gram.Entry.t) + and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) + and _ = (str_item : 'str_item Gram.Entry.t) + and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) + and _ = (sig_items : 'sig_items Gram.Entry.t) + and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) + and _ = (sig_item : 'sig_item Gram.Entry.t) + and _ = (sequence : 'sequence Gram.Entry.t) + and _ = (semi : 'semi Gram.Entry.t) + and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) + and _ = (sem_patt : 'sem_patt Gram.Entry.t) + and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) + and _ = (sem_expr : 'sem_expr Gram.Entry.t) + and _ = (row_field : 'row_field Gram.Entry.t) + and _ = (poly_type : 'poly_type Gram.Entry.t) + and _ = (phrase : 'phrase Gram.Entry.t) + and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) + and _ = (patt_quot : 'patt_quot Gram.Entry.t) + and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) + and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) + and _ = (patt : 'patt Gram.Entry.t) + and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) + and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) + and _ = (opt_rec : 'opt_rec Gram.Entry.t) + and _ = (opt_private : 'opt_private Gram.Entry.t) + and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) + and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) + and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) + and _ = (opt_expr : 'opt_expr Gram.Entry.t) + and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) + and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) + and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) + and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) + and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) + and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) + and _ = (name_tags : 'name_tags Gram.Entry.t) + and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) + and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) + and _ = (module_type : 'module_type Gram.Entry.t) + and _ = + (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) + and _ = + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t) + and _ = (module_longident : 'module_longident Gram.Entry.t) + and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) + and _ = (module_expr : 'module_expr Gram.Entry.t) + and _ = (module_declaration : 'module_declaration Gram.Entry.t) + and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) + and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) + and _ = (module_binding : 'module_binding Gram.Entry.t) + and _ = (meth_decl : 'meth_decl Gram.Entry.t) + and _ = (meth_list : 'meth_list Gram.Entry.t) + and _ = (let_binding : 'let_binding Gram.Entry.t) + and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) + and _ = (label_patt_list : 'label_patt_list Gram.Entry.t) + and _ = (label_patt : 'label_patt Gram.Entry.t) + and _ = (label_longident : 'label_longident Gram.Entry.t) + and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) + and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) + and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) + and _ = (label_expr : 'label_expr Gram.Entry.t) + and _ = + (label_declaration_list : 'label_declaration_list Gram.Entry.t) + and _ = (label_declaration : 'label_declaration Gram.Entry.t) + and _ = (label : 'label Gram.Entry.t) + and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) + and _ = (ipatt : 'ipatt Gram.Entry.t) + and _ = (interf : 'interf Gram.Entry.t) + and _ = (implem : 'implem Gram.Entry.t) + and _ = (ident_quot : 'ident_quot Gram.Entry.t) + and _ = (ident : 'ident Gram.Entry.t) + and _ = (fun_def : 'fun_def Gram.Entry.t) + and _ = (fun_binding : 'fun_binding Gram.Entry.t) + and _ = (field_expr_list : 'field_expr_list Gram.Entry.t) + and _ = (field_expr : 'field_expr Gram.Entry.t) + and _ = (expr_quot : 'expr_quot Gram.Entry.t) + and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) + and _ = (expr : 'expr Gram.Entry.t) + and _ = (eq_expr : 'eq_expr Gram.Entry.t) + and _ = (dummy : 'dummy Gram.Entry.t) + and _ = (direction_flag : 'direction_flag Gram.Entry.t) + and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) + and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) + and _ = (ctyp : 'ctyp Gram.Entry.t) + and _ = + (constructor_declarations : + 'constructor_declarations Gram.Entry.t) + and _ = + (constructor_declaration : + 'constructor_declaration Gram.Entry.t) + and _ = + (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) + and _ = (constrain : 'constrain Gram.Entry.t) + and _ = + (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) + and _ = (comma_patt : 'comma_patt Gram.Entry.t) + and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) + and _ = (comma_expr : 'comma_expr Gram.Entry.t) + and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) + and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) + and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) + and _ = + (class_type_longident_and_param : + 'class_type_longident_and_param Gram.Entry.t) + and _ = + (class_type_longident : 'class_type_longident Gram.Entry.t) + and _ = + (class_type_declaration : 'class_type_declaration Gram.Entry.t) + and _ = (class_type : 'class_type Gram.Entry.t) + and _ = (class_structure : 'class_structure Gram.Entry.t) + and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) + and _ = (class_str_item : 'class_str_item Gram.Entry.t) + and _ = (class_signature : 'class_signature Gram.Entry.t) + and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) + and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) + and _ = + (class_name_and_param : 'class_name_and_param Gram.Entry.t) + and _ = + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t) + and _ = (class_longident : 'class_longident Gram.Entry.t) + and _ = + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t) + and _ = + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t) + and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) + and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) + and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) + and _ = (class_expr : 'class_expr Gram.Entry.t) + and _ = (class_description : 'class_description Gram.Entry.t) + and _ = (class_declaration : 'class_declaration Gram.Entry.t) + and _ = (binding_quot : 'binding_quot Gram.Entry.t) + and _ = (binding : 'binding Gram.Entry.t) + and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) + and _ = (match_case0 : 'match_case0 Gram.Entry.t) + and _ = (match_case : 'match_case Gram.Entry.t) + and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) + and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) + and _ = (a_ident : 'a_ident Gram.Entry.t) + and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) + and _ = (a_STRING : 'a_STRING Gram.Entry.t) + and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) + and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) + and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) + and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) + and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) + and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) + and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) + and _ = (a_INT : 'a_INT Gram.Entry.t) + and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *) + (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t = + grammar_entry_create "infixop5" + and (* | i = opt_label; "("; p = patt_tcon; ")" -> *) + (* <:patt< ? $i$ : ($p$) >> *) + (* | i = opt_label; "("; p = ipatt_tcon; ")" -> <:patt< ? $i$ : ($p$) >> | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> <:patt< ? $i$ : ($p$ = $e$) >> *) - string_list : 'string_list Gram.Entry.t = - grammar_entry_create "string_list" - and opt_override : 'opt_override Gram.Entry.t = - grammar_entry_create "opt_override" - and unquoted_typevars : 'unquoted_typevars Gram.Entry.t = - grammar_entry_create "unquoted_typevars" - and value_val_opt_override : 'value_val_opt_override Gram.Entry.t = - grammar_entry_create "value_val_opt_override" - and method_opt_override : 'method_opt_override Gram.Entry.t = - grammar_entry_create "method_opt_override" - and module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t = - grammar_entry_create "module_longident_dot_lparen" - and optional_type_parameter : - 'optional_type_parameter Gram.Entry.t = - grammar_entry_create "optional_type_parameter" - and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t = - grammar_entry_create "fun_def_cont_no_when" - and fun_def_cont : 'fun_def_cont Gram.Entry.t = - grammar_entry_create "fun_def_cont" - and sequence' : 'sequence' Gram.Entry.t = - grammar_entry_create "sequence'" - and infixop6 : 'infixop6 Gram.Entry.t = - grammar_entry_create "infixop6" - in - (Gram.extend (module_expr : 'module_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "struct"; - Gram.Snterm - (Gram.Entry.obj - (str_items : 'str_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t) - -> (Ast.MeStr (_loc, st) : 'module_expr)))); - ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ (t : 'module_type) - _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (me2 : 'module_expr) (me1 : 'module_expr) - (_loc : Gram.Loc.t) -> - (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ (e : 'expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, - (Ast.ExTyc (_loc, e, - (Ast.TyPkg (_loc, p))))) : - 'module_expr)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, e) : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (me : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ (me : 'module_expr) - _ (_loc : Gram.Loc.t) -> - (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) (_loc : Gram.Loc.t) - -> (Ast.MeId (_loc, i) : 'module_expr)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_expr_tag : - 'module_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "mexp" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mexp" | "anti" | "list" as n)), - s) -> - (Ast.MeAnt (_loc, - (mk_anti ~c: "module_expr" n s)) : - 'module_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (str_item : 'str_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.StExp (_loc, e) : 'str_item)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.str_item_tag : - 'str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "stri" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti ~c: "str_item" n s)) : - 'str_item) - | _ -> assert false))); - ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StClt (_loc, ctd) : 'str_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_declaration : - 'class_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StCls (_loc, cd) : 'str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_let : 'value_let Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'binding) (r : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (Ast.StVal (_loc, r, bi) : 'str_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (td : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StTyp (_loc, td) : 'str_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.StOpn (_loc, i) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StMty (_loc, i, mt) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_binding : - 'module_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StRecMod (_loc, mb) : 'str_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StMod (_loc, i, mb) : 'str_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (Ast.StInc (_loc, me) : 'str_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.StExt (_loc, i, t, sl) : 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ - (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, (Ast.OSome i)) : - 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, Ast.ONone) : 'str_item)))) ]) ])) - ()); - Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (me : 'module_binding0)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (_loc : Gram.Loc.t) -> - (Ast.MeTyc (_loc, me, mt) : 'module_binding0)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mb : 'module_binding0) _ - (mt : 'module_type) _ (m : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, m, mt, mb) : - 'module_binding0)))) ]) ])) - ()); - Gram.extend (module_binding : 'module_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("module_binding" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" | "list" as - n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding) _ - (b1 : 'module_binding) (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, b1, b2) : 'module_binding)))) ]) ])) - ()); - Gram.extend (module_type : 'module_type Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself; Gram.Skeyword ")"; - Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (mt : 'module_type) _ _ (t : 'module_type) - _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); - ((Some "with"), None, - [ ([ Gram.Sself; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (wc : 'with_constr) _ (mt : 'module_type) - (_loc : Gram.Loc.t) -> - (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (mt2 : 'module_type) (mt1 : 'module_type) - (_loc : Gram.Loc.t) -> - (module_type_app mt1 mt2 : 'module_type)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (mt2 : 'module_type) _ (mt1 : 'module_type) - (_loc : Gram.Loc.t) -> - (module_type_acc mt1 mt2 : 'module_type)))) ]); - ((Some "sig"), None, - [ ([ Gram.Skeyword "sig"; - Gram.Snterm - (Gram.Entry.obj - (sig_items : 'sig_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) - -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ _ - (_loc : Gram.Loc.t) -> - (Ast.MtOf (_loc, me) : 'module_type)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (mt : 'module_type)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.MtQuo (_loc, i) : 'module_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.MtId (_loc, i) : 'module_type)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_type_tag : - 'module_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "mtyp" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mtyp" | "anti" | "list" as n)), - s) -> - (Ast.MtAnt (_loc, - (mk_anti ~c: "module_type" n s)) : - 'module_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (sig_item : 'sig_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgClt (_loc, ctd) : 'sig_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_description : - 'class_description Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_description) _ - (_loc : Gram.Loc.t) -> - (Ast.SgCls (_loc, cd) : 'sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgVal (_loc, i, t) : 'sig_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgTyp (_loc, t) : 'sig_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.SgOpn (_loc, i) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : - 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_rec_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgRecMod (_loc, mb) : 'sig_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_declaration : - 'module_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_declaration) (i : 'a_UIDENT) - _ (_loc : Gram.Loc.t) -> - (Ast.SgMod (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (Ast.SgInc (_loc, mt) : 'sig_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgExc (_loc, t) : 'sig_item)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.sig_item_tag : - 'sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "sigi" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti ~c: "sig_item" n s)) : - 'sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_declaration : 'module_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mt : 'module_declaration) _ - (t : 'module_type) _ (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : - 'module_declaration)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (mt : 'module_declaration)))) ]) ])) - ()); - Gram.extend - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_rec_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "module_binding" | "anti" | - "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "module_binding" | "anti" | - "list" - as n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (m2 : 'module_rec_declaration) _ - (m1 : 'module_rec_declaration) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, m1, m2) : - 'module_rec_declaration)))) ]) ])) - ()); - Gram.extend (with_constr : 'with_constr Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMoS (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry. - t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyS (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.WcTyS (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry. - t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.WcTyp (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.with_constr_tag : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "with_constr" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "with_constr" | "anti" | "list" - as n)), - s) -> - (Ast.WcAnt (_loc, - (mk_anti ~c: "with_constr" n s)) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (wc2 : 'with_constr) _ (wc1 : 'with_constr) - (_loc : Gram.Loc.t) -> - (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.ExObj (_loc, csp, cst) : 'expr)))); - ([ Gram.Skeyword "while"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExWhi (_loc, (mksequence' _loc e), seq) : - 'expr)))); - ([ Gram.Skeyword "for"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e2 : 'sequence) - (df : 'direction_flag) (e1 : 'sequence) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFor (_loc, i, (mksequence' _loc e1), - (mksequence' _loc e2), df, seq) : - 'expr)))); - ([ Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (_loc : Gram.Loc.t) - -> (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "if"; Gram.Sself; - Gram.Skeyword "then"; Gram.Sself; - Gram.Skeyword "else"; Gram.Sself ], - (Gram.Action.mk - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) - _ (_loc : Gram.Loc.t) -> - (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); - ([ Gram.Skeyword "try"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTry (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "match"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExMat (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (fun_def : 'fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "fun"; Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (a : 'match_case0 list) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) : - 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'module_longident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (mb : 'module_binding0) - (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'expr) _ (bi : 'binding) - (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); - ((Some "where"), None, - [ ([ Gram.Sself; Gram.Skeyword "where"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lb : 'let_binding) (rf : 'opt_rec) _ - (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); - ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (match bigarray_set _loc e1 e2 with - | Some e -> e - | None -> Ast.ExAss (_loc, e1, e2) : 'expr)))) ]); - ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop6 : 'infixop6 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop6) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))) ]); - ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop5 : 'infixop5 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop5) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))) ]); - ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop0 : 'infixop0 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop0) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))) ]); - ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop1 : 'infixop1 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop1) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))) ]); - ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop2 : 'infixop2 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop2) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))) ]); - ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop3 : 'infixop3 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop3) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "mod")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lxor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "land")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop4 : 'infixop4 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop4) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsr")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsl")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "asr")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "unary minus"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "-."; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-." e : 'expr)))); - ([ Gram.Skeyword "-"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-" e : 'expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExLaz (_loc, e) : 'expr)))); - ([ Gram.Skeyword "new"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.ExNew (_loc, i) : 'expr)))); - ([ Gram.Skeyword "assert"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkassert _loc e : 'expr)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, e) : 'expr)))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> - (Ast.ExOlb (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> (Ast.ExLab (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, e) : 'expr)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lab : 'label) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSnd (_loc, e, lab) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (bigarray_get _loc e1 e2 : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "["; - Gram.Sself; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSte (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "("; - Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); - ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (prefixop : 'prefixop Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (f : 'prefixop) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, f, e) : 'expr)))); - ([ Gram.Skeyword "!"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "val"))))) : - 'expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ - (me : 'module_expr) _ _ (_loc : Gram.Loc.t) - -> - (Ast.ExPkg (_loc, (Ast.MeTyc (_loc, me, pt))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExPkg (_loc, me) : 'expr)))); - ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "begin"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) - -> (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) - _ (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mksequence _loc e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (mksequence _loc (Ast.ExSem (_loc, e, seq)) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (el : 'comma_expr) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTup (_loc, (Ast.ExCom (_loc, e, el))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "{<"; - Gram.Snterm - (Gram.Entry.obj - (field_expr_list : - 'field_expr_list Gram.Entry.t)); - Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ (fel : 'field_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, fel) : 'expr)))); - ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : 'expr)))); - ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")"; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ _ (e : 'expr) _ - _ (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, e) : 'expr)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExArr (_loc, el) : 'expr)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExArr (_loc, (Ast.ExNil _loc)) : 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) : - 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'expr) _ - (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> (mk_list last : 'expr)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'expr)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, s) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (val_longident : - 'val_longident Gram.Entry.t))) ], - (Gram.Action.mk - (fun (i : 'val_longident) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, i) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram. - Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'sequence) - (i : 'module_longident_dot_lparen) - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.ExChr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.ExStr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.ExFlo (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.ExNativeInt (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.ExInt64 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.ExInt32 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.ExInt (_loc, s) : 'expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("seq", _) -> true - | _ -> false), - "ANTIQUOT (\"seq\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("seq" as n)), s) -> - (Ast.ExSeq (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.ExTup (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.ExId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("exp" | "" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("exp" | "" | "anti" as n)), s) - -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.expr_tag : - 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (do_sequence : 'do_sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) - (_loc : Gram.Loc.t) -> - (seq : 'e__3)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__3) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__2)))) ]) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ - (_loc : Gram.Loc.t) -> - (seq : 'e__1)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__1) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))) ]) ])) - ()); - Gram.extend (infixop5 : 'infixop5 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop5 - [ ([ Gram.Skeyword "&&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__4)))); - ([ Gram.Skeyword "&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__4)))) ] ], - (Gram.Action.mk - (fun (x : 'e__4) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop5)))) ]) ])) - ()); - Gram.extend (infixop6 : 'infixop6 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop6 - [ ([ Gram.Skeyword "||" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__5)))); - ([ Gram.Skeyword "or" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__5)))) ] ], - (Gram.Action.mk - (fun (x : 'e__5) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop6)))) ]) ])) - ()); - Gram.extend - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (el acc)) : - 'sem_expr_for_list)))) ]) ])) - ()); - Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'comma_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr," n s)) : - 'comma_expr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) - ()); - Gram.extend (dummy : 'dummy Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ])) - ()); - Gram.extend (sequence' : 'sequence' Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (el : 'sequence) _ (_loc : Gram.Loc.t) -> - (fun e -> Ast.ExSem (_loc, e, el) : - 'sequence')))); - ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))); - ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))) ]) ])) - ()); - Gram.extend (sequence : 'sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) - (_loc : Gram.Loc.t) -> (k e : 'sequence)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr;" n s)) : - 'sequence) - | _ -> assert false))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'sequence) _ (i : 'module_longident) _ - _ (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ (mb : 'module_binding0) - (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (mb : 'module_binding0) (m : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLmd (_loc, m, mb, e)) : 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, bi, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (bi : 'binding) (rf : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLet (_loc, rf, bi, e)) : 'sequence)))) ]) ])) - ()); - Gram.extend (binding : 'binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b : 'let_binding) (_loc : Gram.Loc.t) -> - (b : 'binding)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'binding) _ (b1 : 'binding) - (_loc : Gram.Loc.t) -> - (Ast.BiAnd (_loc, b1, b2) : 'binding)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiEq (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - e) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("binding" | "list"), _) -> true - | _ -> false), - "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("binding" | "list" as n)), s) - -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (let_binding : 'let_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) - ()); - Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t) - -> (bi : 'fun_binding)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'labeled_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) : - 'fun_binding)))); - ([ Gram.Stry - (Gram.srules fun_binding - [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__6)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ])) - ()); - Gram.extend (match_case : 'match_case Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) : - 'match_case)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (l : 'match_case0 list) _ - (_loc : Gram.Loc.t) -> - (Ast.mcOr_of_list l : 'match_case)))) ]) ])) - ()); - Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (patt_as_patt_opt : - 'patt_as_patt_opt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_when_expr : - 'opt_when_expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'opt_when_expr) - (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t) - -> (Ast.McArr (_loc, p, w, e) : 'match_case0)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - w, e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - (Ast.ExNil _loc), e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("match_case" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("match_case" | "list" as n)), - s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_when_expr)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (w : 'expr) _ (_loc : Gram.Loc.t) -> - (w : 'opt_when_expr)))) ]) ])) - ()); - Gram.extend (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_as_patt_opt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p1, p2) : - 'patt_as_patt_opt)))) ]) ])) - ()); - Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'label_expr_list) _ - (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : 'label_expr_list)))) ]) ])) - ()); - Gram.extend (label_expr : 'label_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) (_loc : Gram.Loc.t) - -> - (Ast.RbEq (_loc, i, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, i, e) : 'label_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbEq (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - e) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("rec_binding", _) -> true - | _ -> false), - "ANTIQUOT (\"rec_binding\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec_binding" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (fun_def : 'fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def)))); - ([ Gram.Stry - (Gram.srules fun_def - [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__7)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ])) - ()); - Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), e) : 'fun_def_cont)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (_loc : Gram.Loc.t) -> - ((w, e) : 'fun_def_cont)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))))) : - 'fun_def_cont)))); - ([ Gram.Stry - (Gram.srules fun_def_cont - [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__8)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), (Ast.ExFUN (_loc, i, e))) : - 'fun_def_cont)))) ]) ])) - ()); - Gram.extend - (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.srules fun_def_cont_no_when - [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__9)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : - 'fun_def_cont_no_when)))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); - ((Some ".."), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> - (Ast.PaLaz (_loc, p) : 'patt)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt_tcon) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaOlb (_loc, "", p) : 'patt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> (Ast.PaLab (_loc, i, p) : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ (_loc : Gram.Loc.t) - -> (Ast.PaTyp (_loc, i) : 'patt)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, s) : 'patt)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _ - _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'patt)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_patt_list : - 'label_patt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_patt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) -> - (Ast.PaArr (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaArr (_loc, (Ast.PaNil _loc)) : 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]")))) : - 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'patt) _ - (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> (mk_list last : 'patt)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) -> - (Ast.PaNativeInt (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.PaChr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.PaStr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.PaNativeInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'ident) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, i) : 'patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.PaId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), s) - -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'comma_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_patt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) - ()); - Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'sem_patt) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'sem_patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) - ()); - Gram.extend - (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (pl : 'sem_patt_for_list) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - (pl acc)) : - 'sem_patt_for_list)))) ]) ])) - ()); - Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_patt) (_loc : Gram.Loc.t) - -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_patt_list) _ - (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'label_patt_list)))) ]) ])) - ()); - Gram.extend (label_patt : 'label_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) (_loc : Gram.Loc.t) - -> - (Ast.PaEq (_loc, i, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), s) - -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'ipatt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ipatt : 'comma_ipatt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> - (p : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _ - _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'ipatt)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), s) - -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_ipatt_list : - 'label_ipatt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_ipatt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) - ()); - Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'labeled_ipatt)))) ]) ])) - ()); - Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'comma_ipatt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_ipatt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) - ()); - Gram.extend (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> - (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_ipatt_list) _ - (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : - 'label_ipatt_list)))) ]) ])) - ()); - Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_ipatt)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), s) - -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_declaration : 'type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (constrain : 'constrain Gram.Entry.t))) ], - (Gram.Action.mk - (fun (cl : 'constrain list) (tk : 'opt_eq_ctyp) - ((n, tpl) : 'type_ident_and_parameters) - (_loc : Gram.Loc.t) -> - (Ast.TyDcl (_loc, n, tpl, tk, cl) : - 'type_declaration)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_declaration) _ - (t1 : 'type_declaration) (_loc : Gram.Loc.t) - -> - (Ast.TyAnd (_loc, t1, t2) : - 'type_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'type_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (constrain : 'constrain Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - ((t1, t2) : 'constrain)))) ]) ])) - ()); - Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_eq_ctyp)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_kind : 'type_kind Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) -> - (tk : 'opt_eq_ctyp)))) ]) ])) - ()); - Gram.extend (type_kind : 'type_kind Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'type_kind)))) ]) ])) - ()); - Gram.extend - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t))) ], - (Gram.Action.mk - (fun (tpl : 'optional_type_parameter list) - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) - ()); - Gram.extend - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (type_parameters : - 'type_parameters Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tpl : 'type_parameters) - (i : 'type_longident) (_loc : Gram.Loc.t) -> - (tpl (Ast.TyId (_loc, i)) : - 'type_longident_and_parameters)))) ]) ])) - ()); - Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun t -> t : 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> - (fun acc -> Ast.TyApp (_loc, acc, t) : - 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_parameters) - (t1 : 'type_parameter) (_loc : Gram.Loc.t) -> - (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : - 'type_parameters)))) ]) ])) - ()); - Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'type_parameter)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnM _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnP _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'optional_type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'optional_type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ctyp : 'ctyp Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "private"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "private"; - Gram.Snterml - ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)), - "alias") ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); - ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "!"; - Gram.Snterm - (Gram.Entry.obj - (typevars : 'typevars Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ - (_loc : Gram.Loc.t) -> - (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_OPTLABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LABEL : 'a_LABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_LABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (let t = Ast.TyApp (_loc, t1, t2) - in - try Ast.TyId (_loc, (Ast.ident_of_ctyp t)) - with | Invalid_argument _ -> t : - 'ctyp)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (try - Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.ident_of_ctyp t1), - (Ast.ident_of_ctyp t2)))) - with - | Invalid_argument s -> - raise (Stream.Error s) : - 'ctyp)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (package_type : 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyPkg (_loc, p) : 'ctyp)))); - ([ Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (opt_meth_list : - 'opt_meth_list Gram.Entry.t)); - Gram.Skeyword ">" ], - (Gram.Action.mk - (fun _ (t : 'opt_meth_list) _ - (_loc : Gram.Loc.t) -> (t : 'ctyp)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyCls (_loc, i) : 'ctyp)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (t : 'label_declaration_list) _ - (_loc : Gram.Loc.t) -> - (Ast.TyRec (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ (_loc : Gram.Loc.t) - -> (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ - _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) : - 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'constructor_declarations) _ - (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, (Ast.TyNil _loc)) : 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.TyTup (_loc, (Ast.TySta (_loc, t, tl))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'ctyp)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("id", _) -> true - | _ -> false), - "ANTIQUOT (\"id\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("id" as n)), s) -> - (Ast.TyId (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.TyTup (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), s) - -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'ctyp)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) - ()); - Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'star_ctyp)))); - ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp*" n s)) : - 'star_ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'star_ctyp) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (s : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (let (tl, rt) = generalized_type_of_type t - in - Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - (Ast.TyArr (_loc, - (Ast.tyAnd_of_list tl), rt))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declarations)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_declarations) _ - (t1 : 'constructor_declarations) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : - 'constructor_declarations)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declarations) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declaration : - 'constructor_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'constructor_arg_list)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_arg_list) _ - (t1 : 'constructor_arg_list) - (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, t1, t2) : - 'constructor_arg_list)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'constructor_arg_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (label_declaration_list : - 'label_declaration_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'label_declaration_list) _ - (t1 : 'label_declaration) (_loc : Gram.Loc.t) - -> - (Ast.TySem (_loc, t1, t2) : - 'label_declaration_list)))) ]) ])) - ()); - Gram.extend - (label_declaration : 'label_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Skeyword "mutable"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.TyMut (_loc, t))) : - 'label_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - t) : - 'label_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'label_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_ident : 'a_ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))) ]) ])) - ()); - Gram.extend (ident : 'ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident) _ (i : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) : - 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (module_longident : 'module_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'module_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) _ - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'module_longident_with_app) _ - (_loc : Gram.Loc.t) -> - (i : 'module_longident_with_app)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : - 'module_longident_with_app)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_with_app) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : - 'module_longident_dot_lparen)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident_dot_lparen) _ - (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident_dot_lparen)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_dot_lparen) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_longident : 'type_longident Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) (i : 'type_longident) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) _ - (i : 'type_longident) (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'type_longident) _ - (_loc : Gram.Loc.t) -> (i : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'type_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'type_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (label_longident : 'label_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'label_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'label_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'label_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'label_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident : 'class_type_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_longident) (_loc : Gram.Loc.t) - -> (x : 'class_type_longident)))) ]) ])) - ()); - Gram.extend (val_longident : 'val_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ident) (_loc : Gram.Loc.t) -> - (x : 'val_longident)))) ]) ])) - ()); - Gram.extend (class_longident : 'class_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_longident) (_loc : Gram.Loc.t) - -> (x : 'class_longident)))) ]) ])) - ()); - Gram.extend - (class_declaration : 'class_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_binding : - 'class_fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_binding) - (ci : 'class_info_for_class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeEq (_loc, ci, ce) : - 'class_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cdcl" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cdcl" | "anti" | "list" as n)), - s) -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (c2 : 'class_declaration) _ - (c1 : 'class_declaration) (_loc : Gram.Loc.t) - -> - (Ast.CeAnd (_loc, c1, c2) : - 'class_declaration)))) ]) ])) - ()); - Gram.extend - (class_fun_binding : 'class_fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cfb : 'class_fun_binding) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, cfb) : - 'class_fun_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ - (ct : 'class_type_plus) _ (_loc : Gram.Loc.t) - -> - (Ast.CeTyc (_loc, ce, ct) : - 'class_fun_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> - (ce : 'class_fun_binding)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, mv, (Ast.IdLid (_loc, i)), - ot) : - 'class_info_for_class_type)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, mv, (Ast.IdLid (_loc, i)), - ot) : - 'class_info_for_class_expr)))) ]) ])) - ()); - Gram.extend - (class_name_and_param : 'class_name_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, (Ast.TyNil _loc)) : - 'class_name_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_type_parameter : - 'comma_type_parameter Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_type_parameter) _ - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, x) : 'class_name_and_param)))) ]) ])) - ()); - Gram.extend - (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> (t : 'comma_type_parameter)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_type_parameter) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_type_parameter) _ - (t1 : 'comma_type_parameter) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : - 'comma_type_parameter)))) ]) ])) - ()); - Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_comma_ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t) - -> (x : 'opt_comma_ctyp)))) ]) ])) - ()); - Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'comma_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) - ()); - Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> - (ce : 'class_fun_def)))); - ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) (p : 'labeled_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) - ()); - Gram.extend (class_expr : 'class_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.CeLet (_loc, rf, bi, ce) : 'class_expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_def : - 'class_fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) (p : 'labeled_ipatt) - _ (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "label") ], - (Gram.Action.mk - (fun (e : 'expr) (ce : 'class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ce : 'class_expr) _ (_loc : Gram.Loc.t) - -> (ce : 'class_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ - (_loc : Gram.Loc.t) -> - (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); - ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_longident_and_param) - (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cexp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "cexp" | "anti" as n)), s) - -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ci : 'class_longident) (_loc : Gram.Loc.t) - -> - (Ast.CeCon (_loc, Ast.ViNil, ci, - (Ast.TyNil _loc)) : - 'class_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (ci : 'class_longident) (_loc : Gram.Loc.t) - -> - (Ast.CeCon (_loc, Ast.ViNil, ci, t) : - 'class_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_structure : 'class_structure Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_structure - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (cst : 'class_str_item) - (_loc : Gram.Loc.t) -> - (cst : 'e__10)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__10 list) (_loc : Gram.Loc.t) -> - (Ast.crSem_of_list l : 'class_structure)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cst" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cst : 'class_structure) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrSem (_loc, - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s))), - cst) : - 'class_structure) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cst" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_structure) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : - 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'opt_class_self_patt)))) ]) ])) - ()); - Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "initializer"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (se : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.CrIni (_loc, se) : 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CrCtr (_loc, t1, t2) : 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_polyt : 'opt_polyt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (topt : 'opt_polyt) - (l : 'label) (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrMth (_loc, l, o, pf, e, topt) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (mf : 'opt_mutable) _ - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'cvalue_binding) (lab : 'label) - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrVal (_loc, lab, o, mf, e) : - 'class_str_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (opt_override : 'opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_as_lident : - 'opt_as_lident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pb : 'opt_as_lident) (ce : 'class_expr) - (o : 'opt_override) _ (_loc : Gram.Loc.t) -> - (Ast.CrInh (_loc, o, ce, pb) : - 'class_str_item)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_str_item_tag : - 'class_str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cst" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_str_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (method_opt_override : 'method_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "method" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'method_opt_override)))); - ([ Gram.Skeyword "method"; - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'method_opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "method"; Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'method_opt_override)))) ]) ])) - ()); - Gram.extend - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'value_val_opt_override)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'value_val_opt_override) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'value_val_opt_override)))) ]) ])) - ()); - Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - ("" : 'opt_as_lident)))); - ([ Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (i : 'opt_as_lident)))) ]) ])) - ()); - Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_polyt)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (t : 'opt_polyt)))) ]) ])) - ()); - Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (match t with - | Ast.TyPol (_, _, _) -> - raise - (Stream.Error - "unexpected polytype here") - | _ -> Ast.ExCoe (_loc, e, t, t2) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'poly_type) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); - ([ Gram.Skeyword ":"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (unquoted_typevars : - 'unquoted_typevars Gram.Entry.t)); - Gram.Skeyword "."; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t1 : 'unquoted_typevars) _ _ - (_loc : Gram.Loc.t) -> - (let u = Ast.TyTypePol (_loc, t1, t2) - in Ast.ExTyc (_loc, e, u) : 'cvalue_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'cvalue_binding)))) ]) ])) - ()); - Gram.extend (label : 'label Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'label)))) ]) ])) - ()); - Gram.extend (class_type : 'class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_type : - 'opt_class_self_type Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_signature : - 'class_signature Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (csg : 'class_signature) - (cst : 'opt_class_self_type) _ - (_loc : Gram.Loc.t) -> - (Ast.CtSig (_loc, cst, csg) : 'class_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident_and_param : - 'class_type_longident_and_param Gram. - Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_longident_and_param) - (_loc : Gram.Loc.t) -> (ct : 'class_type)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "ctyp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "ctyp" | "anti" as n)), s) - -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, - (Ast.TyNil _loc)) : - 'class_type_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, t) : - 'class_type_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) (_loc : Gram.Loc.t) -> - (ct : 'class_type_plus)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "]"; Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CtFun (_loc, t, ct) : 'class_type_plus)))) ]) ])) - ()); - Gram.extend - (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_class_self_type)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'opt_class_self_type)))) ]) ])) - ()); - Gram.extend (class_signature : 'class_signature Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_signature - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (csg : 'class_sig_item) - (_loc : Gram.Loc.t) -> - (csg : 'e__11)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__11 list) (_loc : Gram.Loc.t) -> - (Ast.cgSem_of_list l : 'class_signature)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "csg" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (csg : 'class_signature) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgSem (_loc, - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s))), - csg) : - 'class_signature) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "csg" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_signature) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CgCtr (_loc, t1, t2) : 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) _ (_loc : Gram.Loc.t) -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ (_loc : Gram.Loc.t) -> - (Ast.CgMth (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ _ (_loc : Gram.Loc.t) - -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (l : 'label) - (mv : 'opt_virtual) (mf : 'opt_mutable) _ - (_loc : Gram.Loc.t) -> - (Ast.CgVal (_loc, l, mf, mv, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) -> - (Ast.CgInh (_loc, cs) : 'class_sig_item)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_sig_item_tag : - 'class_sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "csg" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))); - ([ Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))) ]) ])) - ()); - Gram.extend - (class_description : 'class_description Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtCol (_loc, ci, ct) : - 'class_description)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_description) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_description) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_description) _ - (cd1 : 'class_description) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_description)))) ]) ])) - ()); - Gram.extend - (class_type_declaration : - 'class_type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtEq (_loc, ci, ct) : - 'class_type_declaration)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_type_declaration) _ - (cd1 : 'class_type_declaration) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_type_declaration)))) ]) ])) - ()); - Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'field_expr_list) _ - (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : 'field_expr_list)))) ]) ])) - ()); - Gram.extend (field_expr : 'field_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) _ (l : 'label) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) : - 'field_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "bi" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "bi" | "anti" as n)), s) - -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (meth_list : 'meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (m : 'meth_decl) - (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - (((Ast.TySem (_loc, m, ml)), v) : 'meth_list)))) ]) ])) - ()); - Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (lab : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, lab)))), - t) : - 'meth_decl)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'meth_decl) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (Ast.TyObj (_loc, (Ast.TyNil _loc), v) : - 'opt_meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_list : 'meth_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) (_loc : Gram.Loc.t) - -> (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) - ()); - Gram.extend (poly_type : 'poly_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'poly_type)))) ]) ])) - ()); - Gram.extend (package_type : 'package_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'module_type) (_loc : Gram.Loc.t) -> - (p : 'package_type)))) ]) ])) - ()); - Gram.extend (typevars : 'typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'typevars)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'typevars) (t1 : 'typevars) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) - ()); - Gram.extend - (unquoted_typevars : 'unquoted_typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'unquoted_typevars)))); - ([ Gram.Stoken - (((function | QUOTATION _ -> true | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'unquoted_typevars) - (t1 : 'unquoted_typevars) (_loc : Gram.Loc.t) - -> - (Ast.TyApp (_loc, t1, t2) : - 'unquoted_typevars)))) ]) ])) - ()); - Gram.extend (row_field : 'row_field Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'row_field)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'row_field) _ (t1 : 'row_field) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : 'row_field)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'row_field) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'row_field) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'amp_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp&" n s)) : - 'amp_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) - ()); - Gram.extend (name_tags : 'name_tags Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'name_tags)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'name_tags) (t1 : 'name_tags) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'name_tags) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlb (_loc, i, p) : - 'eq_expr)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlbi (_loc, i, p, e) : - 'eq_expr)))) ]) ])) - ()); - Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt_tcon) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaOlb (_loc, "", p) : 'ipatt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.PaLab (_loc, i, p) : 'ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'ipatt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) - ()); - Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | ANTIQUOT (("to" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"to\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("to" | "anti" as n)), s) -> - (Ast.DiAnt (mk_anti n s) : - 'direction_flag) - | _ -> assert false))); - ([ Gram.Skeyword "downto" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiDownto : 'direction_flag)))); - ([ Gram.Skeyword "to" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiTo : 'direction_flag)))) ]) ])) - ()); - Gram.extend (opt_private : 'opt_private Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PrNil : 'opt_private)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("private" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"private\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("private" | "anti" as n)), s) - -> - (Ast.PrAnt (mk_anti n s) : 'opt_private) - | _ -> assert false))); - ([ Gram.Skeyword "private" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PrPrivate : 'opt_private)))) ]) ])) - ()); - Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MuNil : 'opt_mutable)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("mutable" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("mutable" | "anti" as n)), s) - -> - (Ast.MuAnt (mk_anti n s) : 'opt_mutable) - | _ -> assert false))); - ([ Gram.Skeyword "mutable" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.MuMutable : 'opt_mutable)))) ]) ])) - ()); - Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ViNil : 'opt_virtual)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("virtual" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" | "anti" as n)), s) - -> - (Ast.ViAnt (mk_anti n s) : 'opt_virtual) - | _ -> assert false))); - ([ Gram.Skeyword "virtual" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ViVirtual : 'opt_virtual)))) ]) ])) - ()); - Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RvNil : 'opt_dot_dot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ((".." | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"..\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (((".." | "anti" as n)), s) -> - (Ast.RvAnt (mk_anti n s) : 'opt_dot_dot) - | _ -> assert false))); - ([ Gram.Skeyword ".." ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.RvRowVar : 'opt_dot_dot)))) ]) ])) - ()); - Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ReNil : 'opt_rec)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("rec" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec" | "anti" as n)), s) -> - (Ast.ReAnt (mk_anti n s) : 'opt_rec) - | _ -> assert false))); - ([ Gram.Skeyword "rec" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ReRecursive : 'opt_rec)))) ]) ])) - ()); - Gram.extend (opt_override : 'opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'opt_override)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : 'opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'opt_override)))) ]) ])) - ()); - Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'opt_expr)))) ]) ])) - ()); - Gram.extend (interf : 'interf Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'interf) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'interf) _ - (si : 'sig_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'interf)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.SgDir (_loc, n, dp) ], - (stopped_at _loc)) : 'interf)))) ]) ])) - ()); - Gram.extend (sig_items : 'sig_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules sig_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sg : 'sig_item) - (_loc : Gram.Loc.t) -> - (sg : 'e__12)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__12 list) (_loc : Gram.Loc.t) -> - (Ast.sgSem_of_list l : 'sig_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "sigi" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg : 'sig_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgSem (_loc, - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s))), - sg) : - 'sig_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "sigi" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s)) : - 'sig_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (implem : 'implem Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'implem) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'implem) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'implem)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'implem)))) ]) ])) - ()); - Gram.extend (str_items : 'str_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules str_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) - (_loc : Gram.Loc.t) -> - (st : 'e__13)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__13 list) (_loc : Gram.Loc.t) -> - (Ast.stSem_of_list l : 'str_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "stri" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st : 'str_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StSem (_loc, - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s))), - st) : - 'str_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "stri" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s)) : - 'str_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (None : 'top_phrase) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj (phrase : 'phrase Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ph : 'phrase) (_loc : Gram.Loc.t) -> - (Some ph : 'top_phrase)))) ]) ])) - ()); - Gram.extend (use_file : 'use_file Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'use_file) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'use_file) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'use_file)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'use_file)))) ]) ])) - ()); - Gram.extend (phrase : 'phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'phrase)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) - ()); - Gram.extend (a_INT : 'a_INT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | INT (_, _) -> true | _ -> false), - "INT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT (_, s) -> (s : 'a_INT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int" | "`int"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "int" | "`int" as n)), s) - -> (mk_anti n s : 'a_INT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | INT32 (_, _) -> true | _ -> false), - "INT32 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT32 (_, s) -> (s : 'a_INT32) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int32" | "`int32"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "int32" | "`int32" as n)), - s) -> (mk_anti n s : 'a_INT32) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | INT64 (_, _) -> true | _ -> false), - "INT64 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT64 (_, s) -> (s : 'a_INT64) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int64" | "`int64"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "int64" | "`int64" as n)), - s) -> (mk_anti n s : 'a_INT64) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | NATIVEINT (_, _) -> true - | _ -> false), - "NATIVEINT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "nativeint" | "`nativeint"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "nativeint" | "`nativeint" as n)), - s) -> (mk_anti n s : 'a_NATIVEINT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | FLOAT (_, _) -> true | _ -> false), - "FLOAT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | FLOAT (_, s) -> (s : 'a_FLOAT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "flo" | "`flo"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "flo" | "`flo" as n)), s) - -> (mk_anti n s : 'a_FLOAT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | CHAR (_, _) -> true | _ -> false), - "CHAR (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | CHAR (_, s) -> (s : 'a_CHAR) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "chr" | "`chr"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "chr" | "`chr" as n)), s) - -> (mk_anti n s : 'a_CHAR) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | UIDENT _ -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT s -> (s : 'a_UIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "uid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"uid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "uid" as n)), s) -> - (mk_anti n s : 'a_UIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT s -> (s : 'a_LIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), s) -> - (mk_anti n s : 'a_LIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL s -> (s : 'a_LABEL) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_LABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL s -> (s : 'a_OPTLABEL) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_OPTLABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, s) -> (s : 'a_STRING) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str" | "`str"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "str" | "`str" as n)), s) - -> (mk_anti n s : 'a_STRING) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (string_list : 'string_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, Ast.LNil) : 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")); - Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'string_list) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, xs) : 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str_list"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (("" | "str_list"), s) -> - (Ast.LAnt (mk_anti "str_list" s) : - 'string_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (value_let : 'value_let Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'value_let)))) ]) ])) - ()); - Gram.extend (value_val : 'value_val Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'value_val)))) ]) ])) - ()); - Gram.extend (semi : 'semi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ])) - ()); - Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'sem_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) - ()); - Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'patt) (_loc : Gram.Loc.t) -> - (x : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (let i = - match x with - | Ast.PaAnt (loc, s) -> Ast.IdAnt (loc, s) - | p -> Ast.ident_of_patt p - in Ast.PaEq (_loc, i, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'sem_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, x, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) - ()); - Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (x : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "and"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'star_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'label_declaration_list) _ - (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, (Ast.TyOfAmp (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'constructor_declarations) _ - (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_declarations) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'label_declaration_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) - ()); - Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_parameter) (_loc : Gram.Loc.t) - -> (x : 'more_ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> - (x : 'more_ctyp)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, x) : 'more_ctyp)))); - ([ Gram.Skeyword "mutable"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) - ()); - Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.StNil _loc : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st2 : 'str_item_quot) _ (st1 : 'str_item) - (_loc : Gram.Loc.t) -> - (match st2 with - | Ast.StNil _ -> st1 - | _ -> Ast.StSem (_loc, st1, st2) : - 'str_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) - ()); - Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.SgNil _loc : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg : 'sig_item) (_loc : Gram.Loc.t) -> - (sg : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item) - (_loc : Gram.Loc.t) -> - (match sg2 with - | Ast.SgNil _ -> sg1 - | _ -> Ast.SgSem (_loc, sg1, sg2) : - 'sig_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) - ()); - Gram.extend (module_type_quot : 'module_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MtNil _loc : 'module_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_type) (_loc : Gram.Loc.t) -> - (x : 'module_type_quot)))) ]) ])) - ()); - Gram.extend (module_expr_quot : 'module_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MeNil _loc : 'module_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_expr) (_loc : Gram.Loc.t) -> - (x : 'module_expr_quot)))) ]) ])) - ()); - Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.McNil _loc : 'match_case_quot)))); - ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")) ], - (Gram.Action.mk - (fun (x : 'match_case0 list) (_loc : Gram.Loc.t) - -> (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ])) - ()); - Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.BiNil _loc : 'binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'binding) (_loc : Gram.Loc.t) -> - (x : 'binding_quot)))) ]) ])) - ()); - Gram.extend (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RbNil _loc : 'rec_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_expr_list) (_loc : Gram.Loc.t) - -> (x : 'rec_binding_quot)))) ]) ])) - ()); - Gram.extend - (module_binding_quot : 'module_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MbNil _loc : 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_binding_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbCol (_loc, (mk_anti n m), mt) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("module_binding" | "anti"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" as n)), s) - -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding_quot) _ - (b1 : 'module_binding_quot) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, b1, b2) : - 'module_binding_quot)))) ]) ])) - ()); - Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) _ (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t) - -> (i : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident_quot) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident_quot) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), s) - -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident_quot) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CeNil _loc : 'class_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_expr) (_loc : Gram.Loc.t) -> - (x : 'class_expr_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_expr" n s) - in Ast.CeCon (_loc, anti, i, ot) : - 'class_expr_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t) - -> - (Ast.CeEq (_loc, ce1, ce2) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t) - -> - (Ast.CeAnd (_loc, ce1, ce2) : - 'class_expr_quot)))) ]) ])) - ()); - Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CtNil _loc : 'class_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_type_plus) (_loc : Gram.Loc.t) - -> (x : 'class_type_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_type" n s) - in Ast.CtCon (_loc, anti, i, ot) : - 'class_type_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) - -> - (Ast.CtCol (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) - -> - (Ast.CtEq (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) - -> - (Ast.CtAnd (_loc, ct1, ct2) : - 'class_type_quot)))) ]) ])) - ()); - Gram.extend - (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CrNil _loc : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_str_item) (_loc : Gram.Loc.t) - -> (x : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_str_item_quot) _ - (x1 : 'class_str_item) (_loc : Gram.Loc.t) -> - (match x2 with - | Ast.CrNil _ -> x1 - | _ -> Ast.CrSem (_loc, x1, x2) : - 'class_str_item_quot)))) ]) ])) - ()); - Gram.extend - (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CgNil _loc : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_sig_item) (_loc : Gram.Loc.t) - -> (x : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_sig_item_quot) _ - (x1 : 'class_sig_item) (_loc : Gram.Loc.t) -> - (match x2 with - | Ast.CgNil _ -> x1 - | _ -> Ast.CgSem (_loc, x1, x2) : - 'class_sig_item_quot)))) ]) ])) - ()); - Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.WcNil _loc : 'with_constr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'with_constr) (_loc : Gram.Loc.t) -> - (x : 'with_constr_quot)))) ]) ])) - ()); - Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_rec) (_loc : Gram.Loc.t) -> - (x : 'rec_flag_quot)))) ]) ])) - ()); - Gram.extend - (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'direction_flag) (_loc : Gram.Loc.t) - -> (x : 'direction_flag_quot)))) ]) ])) - ()); - Gram.extend - (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) -> - (x : 'mutable_flag_quot)))) ]) ])) - ()); - Gram.extend - (private_flag_quot : 'private_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_private) (_loc : Gram.Loc.t) -> - (x : 'private_flag_quot)))) ]) ])) - ()); - Gram.extend - (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) -> - (x : 'virtual_flag_quot)))) ]) ])) - ()); - Gram.extend - (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (x : 'row_var_flag_quot)))) ]) ])) - ()); - Gram.extend - (override_flag_quot : 'override_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_override : 'opt_override Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_override) (_loc : Gram.Loc.t) -> - (x : 'override_flag_quot)))) ]) ])) - ()); - Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'patt_eoi) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'expr_eoi) - | _ -> assert false))) ]) ])) - ())) + string_list : 'string_list Gram.Entry.t = + grammar_entry_create "string_list" + and opt_override : 'opt_override Gram.Entry.t = + grammar_entry_create "opt_override" + and unquoted_typevars : 'unquoted_typevars Gram.Entry.t = + grammar_entry_create "unquoted_typevars" + and value_val_opt_override : + 'value_val_opt_override Gram.Entry.t = + grammar_entry_create "value_val_opt_override" + and method_opt_override : 'method_opt_override Gram.Entry.t = + grammar_entry_create "method_opt_override" + and module_longident_dot_lparen : + 'module_longident_dot_lparen Gram.Entry.t = + grammar_entry_create "module_longident_dot_lparen" + and optional_type_parameter : + 'optional_type_parameter Gram.Entry.t = + grammar_entry_create "optional_type_parameter" + and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t = + grammar_entry_create "fun_def_cont_no_when" + and fun_def_cont : 'fun_def_cont Gram.Entry.t = + grammar_entry_create "fun_def_cont" + and sequence' : 'sequence' Gram.Entry.t = + grammar_entry_create "sequence'" + and infixop6 : 'infixop6 Gram.Entry.t = + grammar_entry_create "infixop6" + in + (Gram.extend (module_expr : 'module_expr Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "struct"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t) + -> (Ast.MeStr (_loc, st) : 'module_expr)))); + ([ Gram.Skeyword "functor"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. + Sself ], + (Gram.Action.mk + (fun (me : 'module_expr) _ _ + (t : 'module_type) _ (i : 'a_UIDENT) _ _ + (_loc : Gram.Loc.t) -> + (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); + ((Some "apply"), None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (me2 : 'module_expr) (me1 : 'module_expr) + (_loc : Gram.Loc.t) -> + (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (package_type : + 'package_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'package_type) _ (e : 'expr) _ _ + (_loc : Gram.Loc.t) -> + (Ast.MePkg (_loc, + (Ast.ExTyc (_loc, e, + (Ast.TyPkg (_loc, p))))) : + 'module_expr)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> + (Ast.MePkg (_loc, e) : 'module_expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (me : 'module_expr) _ + (_loc : Gram.Loc.t) -> (me : 'module_expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (mt : 'module_type) _ + (me : 'module_expr) _ (_loc : Gram.Loc.t) + -> + (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) + (_loc : Gram.Loc.t) -> + (Ast.MeId (_loc, i) : 'module_expr)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.module_expr_tag : + 'module_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "mexp" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "mexp" | "anti" | "list" as n)), + s) -> + (Ast.MeAnt (_loc, + (mk_anti ~c: "module_expr" n s)) : + 'module_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (str_item : 'str_item Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Gram.Loc.t) -> + (Ast.StExp (_loc, e) : 'str_item)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.str_item_tag : + 'str_item) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "stri" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "stri" | "anti" | "list" as n)), + s) -> + (Ast.StAnt (_loc, + (mk_anti ~c: "str_item" n s)) : + 'str_item) + | _ -> assert false))); + ([ Gram.Skeyword "class"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (class_type_declaration : + 'class_type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ctd : 'class_type_declaration) _ _ + (_loc : Gram.Loc.t) -> + (Ast.StClt (_loc, ctd) : 'str_item)))); + ([ Gram.Skeyword "class"; + Gram.Snterm + (Gram.Entry.obj + (class_declaration : + 'class_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cd : 'class_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.StCls (_loc, cd) : 'str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_let : 'value_let Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (bi : 'binding) (r : 'opt_rec) _ + (_loc : Gram.Loc.t) -> + (Ast.StVal (_loc, r, bi) : 'str_item)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_declaration : + 'type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (td : 'type_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.StTyp (_loc, td) : 'str_item)))); + ([ Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.StOpn (_loc, i) : 'str_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ + (_loc : Gram.Loc.t) -> + (Ast.StMty (_loc, i, mt) : 'str_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; + Gram.Snterm + (Gram.Entry.obj + (module_binding : + 'module_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_binding) _ _ + (_loc : Gram.Loc.t) -> + (Ast.StRecMod (_loc, mb) : 'str_item)))); + ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.StMod (_loc, i, mb) : 'str_item)))); + ([ Gram.Skeyword "include"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) + -> (Ast.StInc (_loc, me) : 'str_item)))); + ([ Gram.Skeyword "external"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (string_list : 'string_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sl : 'string_list) _ (t : 'ctyp) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.StExt (_loc, i, t, sl) : 'str_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'type_longident) _ + (t : 'constructor_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.StExc (_loc, t, (Ast.OSome i)) : + 'str_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.StExc (_loc, t, Ast.ONone) : + 'str_item)))) ]) ])) + ()); + Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) + -> (me : 'module_binding0)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) + _ (_loc : Gram.Loc.t) -> + (Ast.MeTyc (_loc, me, mt) : + 'module_binding0)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (mb : 'module_binding0) _ + (mt : 'module_type) _ (m : 'a_UIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.MeFun (_loc, m, mt, mb) : + 'module_binding0)))) ]) ])) + ()); + Gram.extend (module_binding : 'module_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) + _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.MbColEq (_loc, m, mt, me) : + 'module_binding)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.module_binding_tag : + 'module_binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) + _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbColEq (_loc, (mk_anti n m), mt, + me) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (Ast.MbAnt (_loc, + (mk_anti ~c: "module_binding" n s)) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("module_binding" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("module_binding" | "anti" | "list" + as n)), + s) -> + (Ast.MbAnt (_loc, + (mk_anti ~c: "module_binding" n s)) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'module_binding) _ + (b1 : 'module_binding) (_loc : Gram.Loc.t) + -> + (Ast.MbAnd (_loc, b1, b2) : + 'module_binding)))) ]) ])) + ()); + Gram.extend (module_type : 'module_type Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself; + Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. + Sself ], + (Gram.Action.mk + (fun (mt : 'module_type) _ _ + (t : 'module_type) _ (i : 'a_UIDENT) _ _ + (_loc : Gram.Loc.t) -> + (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); + ((Some "with"), None, + [ ([ Gram.Sself; Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (with_constr : 'with_constr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (wc : 'with_constr) _ (mt : 'module_type) + (_loc : Gram.Loc.t) -> + (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); + ((Some "apply"), None, + [ ([ Gram.Sself; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (mt2 : 'module_type) + (mt1 : 'module_type) (_loc : Gram.Loc.t) -> + (module_type_app mt1 mt2 : 'module_type)))) ]); + ((Some "."), None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (mt2 : 'module_type) _ + (mt1 : 'module_type) (_loc : Gram.Loc.t) -> + (module_type_acc mt1 mt2 : 'module_type)))) ]); + ((Some "sig"), None, + [ ([ Gram.Skeyword "sig"; + Gram.Snterm + (Gram.Entry.obj + (sig_items : 'sig_items Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) + -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ _ _ + (_loc : Gram.Loc.t) -> + (Ast.MtOf (_loc, me) : 'module_type)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (mt : 'module_type) _ + (_loc : Gram.Loc.t) -> (mt : 'module_type)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.MtQuo (_loc, i) : 'module_type)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident_with_app) + (_loc : Gram.Loc.t) -> + (Ast.MtId (_loc, i) : 'module_type)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.module_type_tag : + 'module_type) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "mtyp" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "mtyp" | "anti" | "list" as n)), + s) -> + (Ast.MtAnt (_loc, + (mk_anti ~c: "module_type" n s)) : + 'module_type) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (sig_item : 'sig_item Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (class_type_declaration : + 'class_type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ctd : 'class_type_declaration) _ _ + (_loc : Gram.Loc.t) -> + (Ast.SgClt (_loc, ctd) : 'sig_item)))); + ([ Gram.Skeyword "class"; + Gram.Snterm + (Gram.Entry.obj + (class_description : + 'class_description Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cd : 'class_description) _ + (_loc : Gram.Loc.t) -> + (Ast.SgCls (_loc, cd) : 'sig_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.SgVal (_loc, i, t) : 'sig_item)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_declaration : + 'type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.SgTyp (_loc, t) : 'sig_item)))); + ([ Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.SgOpn (_loc, i) : 'sig_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> + (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : + 'sig_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ + (_loc : Gram.Loc.t) -> + (Ast.SgMty (_loc, i, mt) : 'sig_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; + Gram.Snterm + (Gram.Entry.obj + (module_rec_declaration : + 'module_rec_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_rec_declaration) _ _ + (_loc : Gram.Loc.t) -> + (Ast.SgRecMod (_loc, mb) : 'sig_item)))); + ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_declaration : + 'module_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_declaration) + (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.SgMod (_loc, i, mt) : 'sig_item)))); + ([ Gram.Skeyword "include"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) + -> (Ast.SgInc (_loc, mt) : 'sig_item)))); + ([ Gram.Skeyword "external"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (string_list : 'string_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sl : 'string_list) _ (t : 'ctyp) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_declaration) _ + (_loc : Gram.Loc.t) -> + (Ast.SgExc (_loc, t) : 'sig_item)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.sig_item_tag : + 'sig_item) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "sigi" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "sigi" | "anti" | "list" as n)), + s) -> + (Ast.SgAnt (_loc, + (mk_anti ~c: "sig_item" n s)) : + 'sig_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_declaration : 'module_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (mt : 'module_declaration) _ + (t : 'module_type) _ (i : 'a_UIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.MtFun (_loc, i, t, mt) : + 'module_declaration)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) + -> (mt : 'module_declaration)))) ]) ])) + ()); + Gram.extend + (module_rec_declaration : + 'module_rec_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (m : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (Ast.MbCol (_loc, m, mt) : + 'module_rec_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.module_binding_tag : + 'module_rec_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "module_binding" | "anti" | + "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "module_binding" | "anti" | + "list" + as n)), + s) -> + (Ast.MbAnt (_loc, + (mk_anti ~c: "module_binding" n s)) : + 'module_rec_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (m2 : 'module_rec_declaration) _ + (m1 : 'module_rec_declaration) + (_loc : Gram.Loc.t) -> + (Ast.MbAnd (_loc, m1, m2) : + 'module_rec_declaration)))) ]) ])) + ()); + Gram.extend (with_constr : 'with_constr Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)); + Gram.Skeyword ":="; + Gram.Snterm + (Gram.Entry.obj + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i2 : 'module_longident_with_app) _ + (i1 : 'module_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.WcMoS (_loc, i1, i2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_longident_and_parameters : + 'type_longident_and_parameters Gram. + Entry.t)); + Gram.Skeyword ":="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ + (t1 : 'type_longident_and_parameters) _ + (_loc : Gram.Loc.t) -> + (Ast.WcTyS (_loc, t1, t2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); + Gram.Skeyword ":="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) + _ (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.WcTyS (_loc, + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s))), + t) : + 'with_constr) + | _ -> assert false))); + ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i2 : 'module_longident_with_app) _ + (i1 : 'module_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_longident_and_parameters : + 'type_longident_and_parameters Gram. + Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ + (t1 : 'type_longident_and_parameters) _ + (_loc : Gram.Loc.t) -> + (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) + _ (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.WcTyp (_loc, + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s))), + t) : + 'with_constr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.with_constr_tag : + 'with_constr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "with_constr" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "with_constr" | "anti" | "list" + as n)), + s) -> + (Ast.WcAnt (_loc, + (mk_anti ~c: "with_constr" n s)) : + 'with_constr) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (wc2 : 'with_constr) _ + (wc1 : 'with_constr) (_loc : Gram.Loc.t) -> + (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) + ()); + Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_patt : + 'opt_class_self_patt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_structure : + 'class_structure Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (cst : 'class_structure) + (csp : 'opt_class_self_patt) _ + (_loc : Gram.Loc.t) -> + (Ast.ExObj (_loc, csp, cst) : 'expr)))); + ([ Gram.Skeyword "while"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "do"; + Gram.Snterm + (Gram.Entry.obj + (do_sequence : 'do_sequence Gram.Entry.t)) ], + (Gram.Action.mk + (fun (seq : 'do_sequence) _ (e : 'sequence) _ + (_loc : Gram.Loc.t) -> + (Ast.ExWhi (_loc, (mksequence' _loc e), + seq) : + 'expr)))); + ([ Gram.Skeyword "for"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (direction_flag : + 'direction_flag Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "do"; + Gram.Snterm + (Gram.Entry.obj + (do_sequence : 'do_sequence Gram.Entry.t)) ], + (Gram.Action.mk + (fun (seq : 'do_sequence) _ (e2 : 'sequence) + (df : 'direction_flag) (e1 : 'sequence) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.ExFor (_loc, i, (mksequence' _loc e1), + (mksequence' _loc e2), df, seq) : + 'expr)))); + ([ Gram.Skeyword "do"; + Gram.Snterm + (Gram.Entry.obj + (do_sequence : 'do_sequence Gram.Entry.t)) ], + (Gram.Action.mk + (fun (seq : 'do_sequence) _ + (_loc : Gram.Loc.t) -> + (mksequence _loc seq : 'expr)))); + ([ Gram.Skeyword "if"; Gram.Sself; + Gram.Skeyword "then"; Gram.Sself; + Gram.Skeyword "else"; Gram.Sself ], + (Gram.Action.mk + (fun (e3 : 'expr) _ (e2 : 'expr) _ + (e1 : 'expr) _ (_loc : Gram.Loc.t) -> + (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); + ([ Gram.Skeyword "try"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)) ], + (Gram.Action.mk + (fun (a : 'match_case) _ (e : 'sequence) _ + (_loc : Gram.Loc.t) -> + (Ast.ExTry (_loc, (mksequence' _loc e), a) : + 'expr)))); + ([ Gram.Skeyword "match"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)) ], + (Gram.Action.mk + (fun (a : 'match_case) _ (e : 'sequence) _ + (_loc : Gram.Loc.t) -> + (Ast.ExMat (_loc, (mksequence' _loc e), a) : + 'expr)))); + ([ Gram.Skeyword "fun"; + Gram.Snterm + (Gram.Entry.obj + (fun_def : 'fun_def Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) -> + (e : 'expr)))); + ([ Gram.Skeyword "fun"; Gram.Skeyword "["; + Gram.Slist0sep + ((Gram.Snterm + (Gram.Entry.obj + (match_case0 : + 'match_case0 Gram.Entry.t))), + (Gram.Skeyword "|")); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (a : 'match_case0 list) _ _ + (_loc : Gram.Loc.t) -> + (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) : + 'expr)))); + ([ Gram.Skeyword "let"; Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (i : 'module_longident) _ _ + (_loc : Gram.Loc.t) -> + (Ast.ExOpI (_loc, i, e) : 'expr)))); + ([ Gram.Skeyword "let"; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (mb : 'module_binding0) + (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> + (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); + ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (x : 'expr) _ (bi : 'binding) + (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> + (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); + ((Some "where"), None, + [ ([ Gram.Sself; Gram.Skeyword "where"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (let_binding : 'let_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (lb : 'let_binding) (rf : 'opt_rec) _ + (e : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); + ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (match bigarray_set _loc e1 e2 with + | Some e -> e + | None -> Ast.ExAss (_loc, e1, e2) : + 'expr)))) ]); + ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop6 : 'infixop6 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop6) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))) ]); + ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop5 : 'infixop5 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop5) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))) ]); + ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop0 : 'infixop0 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop0) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))) ]); + ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop1 : 'infixop1 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop1) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))) ]); + ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop2 : 'infixop2 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop2) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))) ]); + ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop3 : 'infixop3 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop3) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "mod")))), + e1)), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "lxor")))), + e1)), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "lor")))), + e1)), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "land")))), + e1)), + e2) : + 'expr)))) ]); + ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (infixop4 : 'infixop4 Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (op : 'infixop4) + (e1 : 'expr) (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, op, e1)), e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "lsr")))), + e1)), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "lsl")))), + e1)), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "asr")))), + e1)), + e2) : + 'expr)))) ]); + ((Some "unary minus"), + (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "-."; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (mkumin _loc "-." e : 'expr)))); + ([ Gram.Skeyword "-"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (mkumin _loc "-" e : 'expr)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "lazy"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (Ast.ExLaz (_loc, e) : 'expr)))); + ([ Gram.Skeyword "new"; + Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.ExNew (_loc, i) : 'expr)))); + ([ Gram.Skeyword "assert"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (mkassert _loc e : 'expr)))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); + ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) : + 'expr)))); + ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.ExOlb (_loc, i, e) : 'expr)))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> + (Ast.ExOlb (_loc, i, e) : 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LABEL i -> + (Ast.ExLab (_loc, i, e) : 'expr) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) : + 'expr)))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.ExLab (_loc, i, e) : 'expr)))) ]); + ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], + (Gram.Action.mk + (fun (lab : 'label) _ (e : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExSnd (_loc, e, lab) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExAcc (_loc, e1, e2) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; + Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (bigarray_get _loc e1 e2 : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; + Gram.Skeyword "["; Gram.Sself; + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExSte (_loc, e1, e2) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; + Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); + ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (prefixop : 'prefixop Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) (f : 'prefixop) + (_loc : Gram.Loc.t) -> + (Ast.ExApp (_loc, f, e) : 'expr)))); + ([ Gram.Skeyword "!"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (Ast.ExAcc (_loc, e, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, "val"))))) : + 'expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (package_type : + 'package_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pt : 'package_type) _ + (me : 'module_expr) _ _ (_loc : Gram.Loc.t) + -> + (Ast.ExPkg (_loc, + (Ast.MeTyc (_loc, me, pt))) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (me : 'module_expr) _ _ + (_loc : Gram.Loc.t) -> + (Ast.ExPkg (_loc, me) : 'expr)))); + ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : + 'expr)))); + ([ Gram.Skeyword "begin"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) + -> (mksequence _loc seq : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> + (e : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (_loc : Gram.Loc.t) -> + (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ + (e : 'expr) _ (_loc : Gram.Loc.t) -> + (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ";"; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> + (mksequence _loc e : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ (e : 'expr) _ + (_loc : Gram.Loc.t) -> + (mksequence _loc (Ast.ExSem (_loc, e, seq)) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (el : 'comma_expr) _ (e : 'expr) _ + (_loc : Gram.Loc.t) -> + (Ast.ExTup (_loc, + (Ast.ExCom (_loc, e, el))) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (_loc : Gram.Loc.t) -> + (Ast.ExTyc (_loc, e, t) : 'expr)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : + 'expr)))); + ([ Gram.Skeyword "{<"; + Gram.Snterm + (Gram.Entry.obj + (field_expr_list : + 'field_expr_list Gram.Entry.t)); + Gram.Skeyword ">}" ], + (Gram.Action.mk + (fun _ (fel : 'field_expr_list) _ + (_loc : Gram.Loc.t) -> + (Ast.ExOvr (_loc, fel) : 'expr)))); + ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : + 'expr)))); + ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram. + Sself; Gram.Skeyword ")"; Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (label_expr_list : + 'label_expr_list Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (el : 'label_expr_list) _ _ (e : 'expr) + _ _ (_loc : Gram.Loc.t) -> + (Ast.ExRec (_loc, el, e) : 'expr)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_expr_list : + 'label_expr_list Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (el : 'label_expr_list) _ + (_loc : Gram.Loc.t) -> + (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) : + 'expr)))); + ([ Gram.Skeyword "[|"; + Gram.Snterm + (Gram.Entry.obj + (sem_expr : 'sem_expr Gram.Entry.t)); + Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) + -> (Ast.ExArr (_loc, el) : 'expr)))); + ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.ExArr (_loc, (Ast.ExNil _loc)) : + 'expr)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_expr_for_list : + 'sem_expr_for_list Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (mk_list : 'sem_expr_for_list) _ + (_loc : Gram.Loc.t) -> + (mk_list + (Ast.ExId (_loc, + (Ast.IdUid (_loc, "[]")))) : + 'expr)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_expr_for_list : + 'sem_expr_for_list Gram.Entry.t)); + Gram.Skeyword "::"; Gram.Sself; + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (last : 'expr) _ + (mk_list : 'sem_expr_for_list) _ + (_loc : Gram.Loc.t) -> + (mk_list last : 'expr)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) : + 'expr)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.ExVrn (_loc, s) : 'expr)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (val_longident : + 'val_longident Gram.Entry.t))) ], + (Gram.Action.mk + (fun (i : 'val_longident) (_loc : Gram.Loc.t) + -> (Ast.ExId (_loc, i) : 'expr)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (module_longident_dot_lparen : + 'module_longident_dot_lparen Gram. + Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'sequence) + (i : 'module_longident_dot_lparen) + (_loc : Gram.Loc.t) -> + (Ast.ExOpI (_loc, i, e) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_CHAR : 'a_CHAR Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> + (Ast.ExChr (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_STRING : 'a_STRING Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> + (Ast.ExStr (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> + (Ast.ExFlo (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> + (Ast.ExNativeInt (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> + (Ast.ExInt64 (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> + (Ast.ExInt32 (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> + (Ast.ExInt (_loc, s) : 'expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("seq", _) -> true + | _ -> false), + "ANTIQUOT (\"seq\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("seq" as n)), s) -> + (Ast.ExSeq (_loc, + (Ast.ExAnt (_loc, + (mk_anti ~c: "expr" n s)))) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.ExTup (_loc, + (Ast.ExAnt (_loc, + (mk_anti ~c: "expr" n s)))) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("`bool", _) -> true + | _ -> false), + "ANTIQUOT (\"`bool\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("`bool" as n)), s) -> + (Ast.ExId (_loc, + (Ast.IdAnt (_loc, (mk_anti n s)))) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("exp" | "" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("exp" | "" | "anti" as n)), + s) -> + (Ast.ExAnt (_loc, + (mk_anti ~c: "expr" n s)) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.expr_tag : + 'expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (do_sequence : 'do_sequence Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "done" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : + 'do_sequence)))); + ([ Gram.Stry + (Gram.srules do_sequence + [ ([ Gram.Snterm + (Gram.Entry.obj + (sequence : + 'sequence Gram.Entry.t)); + Gram.Skeyword "done" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) + (_loc : Gram.Loc.t) -> + (seq : 'e__3)))) ]) ], + (Gram.Action.mk + (fun (seq : 'e__3) (_loc : Gram.Loc.t) -> + (seq : 'do_sequence)))); + ([ Gram.Stry + (Gram.srules do_sequence + [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (() : 'e__2)))) ]) ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : + 'do_sequence)))); + ([ Gram.Stry + (Gram.srules do_sequence + [ ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (sequence : + 'sequence Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ + (_loc : Gram.Loc.t) -> + (seq : 'e__1)))) ]) ], + (Gram.Action.mk + (fun (seq : 'e__1) (_loc : Gram.Loc.t) -> + (seq : 'do_sequence)))) ]) ])) + ()); + Gram.extend (infixop5 : 'infixop5 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.srules infixop5 + [ ([ Gram.Skeyword "&&" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : + 'e__4)))); + ([ Gram.Skeyword "&" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : + 'e__4)))) ] ], + (Gram.Action.mk + (fun (x : 'e__4) (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : + 'infixop5)))) ]) ])) + ()); + Gram.extend (infixop6 : 'infixop6 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.srules infixop6 + [ ([ Gram.Skeyword "||" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : + 'e__5)))); + ([ Gram.Skeyword "or" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : + 'e__5)))) ] ], + (Gram.Action.mk + (fun (x : 'e__5) (_loc : Gram.Loc.t) -> + (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : + 'infixop6)))) ]) ])) + ()); + Gram.extend + (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdUid (_loc, "::")))), + e)), + acc) : + 'sem_expr_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdUid (_loc, "::")))), + e)), + acc) : + 'sem_expr_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sem_expr_for_list) _ (e : 'expr) + (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdUid (_loc, "::")))), + e)), + (el acc)) : + 'sem_expr_for_list)))) ]) ])) + ()); + Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterml + ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), + "top") ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Gram.Loc.t) -> + (e : 'comma_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.ExAnt (_loc, + (mk_anti ~c: "expr," n s)) : + 'comma_expr) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) + (_loc : Gram.Loc.t) -> + (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) + ()); + Gram.extend (dummy : 'dummy Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ])) + ()); + Gram.extend (sequence' : 'sequence' Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)) ], + (Gram.Action.mk + (fun (el : 'sequence) _ (_loc : Gram.Loc.t) -> + (fun e -> Ast.ExSem (_loc, e, el) : + 'sequence')))); + ([ Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (fun e -> e : 'sequence')))); + ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (fun e -> e : 'sequence')))) ]) ])) + ()); + Gram.extend (sequence : 'sequence Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (sequence' : 'sequence' Gram.Entry.t)) ], + (Gram.Action.mk + (fun (k : 'sequence') (e : 'expr) + (_loc : Gram.Loc.t) -> (k e : 'sequence)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.ExAnt (_loc, + (mk_anti ~c: "expr;" n s)) : + 'sequence) + | _ -> assert false))); + ([ Gram.Skeyword "let"; Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'sequence) _ (i : 'module_longident) + _ _ (_loc : Gram.Loc.t) -> + (Ast.ExOpI (_loc, i, e) : 'sequence)))); + ([ Gram.Skeyword "let"; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sequence) _ + (mb : 'module_binding0) (m : 'a_UIDENT) _ _ + (_loc : Gram.Loc.t) -> + (Ast.ExLmd (_loc, m, mb, + (mksequence _loc el)) : + 'sequence)))); + ([ Gram.Skeyword "let"; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)); + Gram.Skeyword "in"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (sequence' : 'sequence' Gram.Entry.t)) ], + (Gram.Action.mk + (fun (k : 'sequence') (e : 'expr) _ + (mb : 'module_binding0) (m : 'a_UIDENT) _ _ + (_loc : Gram.Loc.t) -> + (k (Ast.ExLmd (_loc, m, mb, e)) : + 'sequence)))); + ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sequence) _ (bi : 'binding) + (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> + (Ast.ExLet (_loc, rf, bi, + (mksequence _loc el)) : + 'sequence)))); + ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword "in"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (sequence' : 'sequence' Gram.Entry.t)) ], + (Gram.Action.mk + (fun (k : 'sequence') (e : 'expr) _ + (bi : 'binding) (rf : 'opt_rec) _ + (_loc : Gram.Loc.t) -> + (k (Ast.ExLet (_loc, rf, bi, e)) : + 'sequence)))) ]) ])) + ()); + Gram.extend (binding : 'binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (let_binding : 'let_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b : 'let_binding) (_loc : Gram.Loc.t) -> + (b : 'binding)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'binding) _ (b1 : 'binding) + (_loc : Gram.Loc.t) -> + (Ast.BiAnd (_loc, b1, b2) : 'binding)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.BiAnt (_loc, + (mk_anti ~c: "binding" n s)) : + 'binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.BiEq (_loc, + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s))), + e) : + 'binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("binding" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("binding" | "list" as n)), s) + -> + (Ast.BiAnt (_loc, + (mk_anti ~c: "binding" n s)) : + 'binding) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (let_binding : 'let_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (p : 'ipatt) + (_loc : Gram.Loc.t) -> + (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) + ()); + Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (cvalue_binding : + 'cvalue_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (bi : 'cvalue_binding) + (_loc : Gram.Loc.t) -> (bi : 'fun_binding)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t))); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'fun_binding) (p : 'labeled_ipatt) + (_loc : Gram.Loc.t) -> + (Ast.ExFun (_loc, + (Ast.McArr (_loc, p, (Ast.ExNil _loc), + e))) : + 'fun_binding)))); + ([ Gram.Stry + (Gram.srules fun_binding + [ ([ Gram.Skeyword "("; + Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (() : 'e__6)))) ]); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ])) + ()); + Gram.extend (match_case : 'match_case Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (p : 'ipatt) + (_loc : Gram.Loc.t) -> + (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) : + 'match_case)))); + ([ Gram.Skeyword "["; + Gram.Slist0sep + ((Gram.Snterm + (Gram.Entry.obj + (match_case0 : + 'match_case0 Gram.Entry.t))), + (Gram.Skeyword "|")); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (l : 'match_case0 list) _ + (_loc : Gram.Loc.t) -> + (Ast.mcOr_of_list l : 'match_case)))) ]) ])) + ()); + Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (patt_as_patt_opt : + 'patt_as_patt_opt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_when_expr : + 'opt_when_expr Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (w : 'opt_when_expr) + (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t) + -> + (Ast.McArr (_loc, p, w, e) : 'match_case0)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (w : 'expr) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McArr (_loc, + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s))), + w, e) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McArr (_loc, + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s))), + (Ast.ExNil _loc), e) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McAnt (_loc, + (mk_anti ~c: "match_case" n s)) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("match_case" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("match_case" | "list" as n)), + s) -> + (Ast.McAnt (_loc, + (mk_anti ~c: "match_case" n s)) : + 'match_case0) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.ExNil _loc : 'opt_when_expr)))); + ([ Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (w : 'expr) _ (_loc : Gram.Loc.t) -> + (w : 'opt_when_expr)))) ]) ])) + ()); + Gram.extend + (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Gram.Loc.t) -> + (p : 'patt_as_patt_opt)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword "as"; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaAli (_loc, p1, p2) : + 'patt_as_patt_opt)))) ]) ])) + ()); + Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> + (b1 : 'label_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) + -> (b1 : 'label_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'label_expr_list) _ + (b1 : 'label_expr) (_loc : Gram.Loc.t) -> + (Ast.RbSem (_loc, b1, b2) : + 'label_expr_list)))) ]) ])) + ()); + Gram.extend (label_expr : 'label_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'label_longident) + (_loc : Gram.Loc.t) -> + (Ast.RbEq (_loc, i, + (Ast.ExId (_loc, + (Ast.IdLid (_loc, (lid_of_ident i)))))) : + 'label_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (i : 'label_longident) + (_loc : Gram.Loc.t) -> + (Ast.RbEq (_loc, i, e) : 'label_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.RbAnt (_loc, + (mk_anti ~c: "rec_binding" n s)) : + 'label_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.RbEq (_loc, + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s))), + e) : + 'label_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.RbAnt (_loc, + (mk_anti ~c: "rec_binding" n s)) : + 'label_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("rec_binding", _) -> true + | _ -> false), + "ANTIQUOT (\"rec_binding\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("rec_binding" as n)), s) -> + (Ast.RbAnt (_loc, + (mk_anti ~c: "rec_binding" n s)) : + 'label_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (fun_def : 'fun_def Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (fun_def_cont : + 'fun_def_cont Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((w, e) : 'fun_def_cont) + (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> + (Ast.ExFun (_loc, + (Ast.McArr (_loc, p, w, e))) : + 'fun_def)))); + ([ Gram.Stry + (Gram.srules fun_def + [ ([ Gram.Skeyword "("; + Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (() : 'e__7)))) ]); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ")"; + Gram.Snterm + (Gram.Entry.obj + (fun_def_cont_no_when : + 'fun_def_cont_no_when Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_def_cont_no_when) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ])) + ()); + Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (((Ast.ExNil _loc), e) : 'fun_def_cont)))); + ([ Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (w : 'expr) _ + (_loc : Gram.Loc.t) -> + ((w, e) : 'fun_def_cont)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t))); + Gram.Sself ], + (Gram.Action.mk + (fun ((w, e) : 'fun_def_cont) + (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> + (((Ast.ExNil _loc), + (Ast.ExFun (_loc, + (Ast.McArr (_loc, p, w, e))))) : + 'fun_def_cont)))); + ([ Gram.Stry + (Gram.srules fun_def_cont + [ ([ Gram.Skeyword "("; + Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (() : 'e__8)))) ]); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ")"; + Gram.Snterm + (Gram.Entry.obj + (fun_def_cont_no_when : + 'fun_def_cont_no_when Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_def_cont_no_when) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (((Ast.ExNil _loc), + (Ast.ExFUN (_loc, i, e))) : + 'fun_def_cont)))) ]) ])) + ()); + Gram.extend + (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (e : 'fun_def_cont_no_when)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (fun_def_cont : + 'fun_def_cont Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((w, e) : 'fun_def_cont) + (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> + (Ast.ExFun (_loc, + (Ast.McArr (_loc, p, w, e))) : + 'fun_def_cont_no_when)))); + ([ Gram.Stry + (Gram.srules fun_def_cont_no_when + [ ([ Gram.Skeyword "("; + Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (() : 'e__9)))) ]); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'fun_def_cont_no_when) _ + (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (Ast.ExFUN (_loc, i, e) : + 'fun_def_cont_no_when)))) ]) ])) + ()); + Gram.extend (patt : 'patt Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); + ((Some ".."), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "lazy"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> + (Ast.PaLaz (_loc, p) : 'patt)))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) (p1 : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ + (_loc : Gram.Loc.t) -> + (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); + ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt_tcon) _ _ + (_loc : Gram.Loc.t) -> + (Ast.PaOlb (_loc, "", p) : 'patt)))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaOlb (_loc, (mk_anti n i), + (Ast.PaNil _loc)) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ + (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (f (mk_anti n i) p : 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> (f i p : 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, (mk_anti n i), + (Ast.PaNil _loc)) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) + _ (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, (mk_anti n i), p) : + 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LABEL i -> + (Ast.PaLab (_loc, i, p) : 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'type_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTyp (_loc, i) : 'patt)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.PaVrn (_loc, s) : 'patt)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.patt_tag : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.PaAny _loc : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_patt : 'comma_patt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pl : 'comma_patt) _ (p : 'patt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTup (_loc, + (Ast.PaCom (_loc, p, pl))) : + 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword "as"; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p2 : 'patt) _ (p : 'patt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaAli (_loc, p, p2) : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> + (p : 'patt)))); + ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (package_type : + 'package_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) + _ _ (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), + (Ast.TyPkg (_loc, pt))) : + 'patt)))); + ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) + -> (Ast.PaMod (_loc, m) : 'patt)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : + 'patt)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_patt_list : + 'label_patt_list Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (pl : 'label_patt_list) _ + (_loc : Gram.Loc.t) -> + (Ast.PaRec (_loc, pl) : 'patt)))); + ([ Gram.Skeyword "[|"; + Gram.Snterm + (Gram.Entry.obj + (sem_patt : 'sem_patt Gram.Entry.t)); + Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) + -> (Ast.PaArr (_loc, pl) : 'patt)))); + ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.PaArr (_loc, (Ast.PaNil _loc)) : + 'patt)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_patt_for_list : + 'sem_patt_for_list Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (mk_list : 'sem_patt_for_list) _ + (_loc : Gram.Loc.t) -> + (mk_list + (Ast.PaId (_loc, + (Ast.IdUid (_loc, "[]")))) : + 'patt)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_patt_for_list : + 'sem_patt_for_list Gram.Entry.t)); + Gram.Skeyword "::"; Gram.Sself; + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (last : 'patt) _ + (mk_list : 'sem_patt_for_list) _ + (_loc : Gram.Loc.t) -> + (mk_list last : 'patt)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) -> + (Ast.PaFlo (_loc, (neg_string s)) : 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) + -> + (Ast.PaNativeInt (_loc, (neg_string s)) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) -> + (Ast.PaInt64 (_loc, (neg_string s)) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) -> + (Ast.PaInt32 (_loc, (neg_string s)) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) -> + (Ast.PaInt (_loc, (neg_string s)) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_CHAR : 'a_CHAR Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> + (Ast.PaChr (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_STRING : 'a_STRING Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> + (Ast.PaStr (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> + (Ast.PaFlo (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> + (Ast.PaNativeInt (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> + (Ast.PaInt64 (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> + (Ast.PaInt32 (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> + (Ast.PaInt (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'ident) (_loc : Gram.Loc.t) -> + (Ast.PaId (_loc, i) : 'patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("`bool", _) -> true + | _ -> false), + "ANTIQUOT (\"`bool\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("`bool" as n)), s) -> + (Ast.PaId (_loc, + (Ast.IdAnt (_loc, (mk_anti n s)))) : + 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.PaTup (_loc, + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)))) : + 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), + s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)) : + 'patt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Gram.Loc.t) -> + (p : 'comma_patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt," n s)) : + 'comma_patt) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) + (_loc : Gram.Loc.t) -> + (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) + ()); + Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Gram.Loc.t) -> + (p : 'sem_patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> + (p : 'sem_patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt;" n s)) : + 'sem_patt) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'sem_patt) _ (p1 : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) + ()); + Gram.extend + (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdUid (_loc, "::")))), + p)), + acc) : + 'sem_patt_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdUid (_loc, "::")))), + p)), + acc) : + 'sem_patt_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (pl : 'sem_patt_for_list) _ (p : 'patt) + (_loc : Gram.Loc.t) -> + (fun acc -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdUid (_loc, "::")))), + p)), + (pl acc)) : + 'sem_patt_for_list)))) ]) ])) + ()); + Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> + (p1 : 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) + -> (p1 : 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_"; + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ _ _ (p1 : 'label_patt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ _ (p1 : 'label_patt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_patt_list) _ + (p1 : 'label_patt) (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : + 'label_patt_list)))) ]) ])) + ()); + Gram.extend (label_patt : 'label_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'label_longident) + (_loc : Gram.Loc.t) -> + (Ast.PaEq (_loc, i, + (Ast.PaId (_loc, + (Ast.IdLid (_loc, (lid_of_ident i)))))) : + 'label_patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) _ (i : 'label_longident) + (_loc : Gram.Loc.t) -> + (Ast.PaEq (_loc, i, p) : 'label_patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt;" n s)) : + 'label_patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.patt_tag : + 'label_patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), + s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)) : + 'label_patt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (ipatt : 'ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.PaAny _loc : 'ipatt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) : + 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_ipatt : 'comma_ipatt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTup (_loc, + (Ast.PaCom (_loc, p, pl))) : + 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword "as"; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaAli (_loc, p, p2) : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'ipatt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> + (p : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (package_type : + 'package_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) + _ _ (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), + (Ast.TyPkg (_loc, pt))) : + 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) + -> (Ast.PaMod (_loc, m) : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : + 'ipatt)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.patt_tag : + 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.PaTup (_loc, + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)))) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), + s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_ipatt_list : + 'label_ipatt_list Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (pl : 'label_ipatt_list) _ + (_loc : Gram.Loc.t) -> + (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) + ()); + Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> + (p : 'labeled_ipatt)))) ]) ])) + ()); + Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> + (p : 'comma_ipatt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt," n s)) : + 'comma_ipatt) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) + (_loc : Gram.Loc.t) -> + (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) + ()); + Gram.extend + (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) + -> (p1 : 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) + -> (p1 : 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_"; + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ _ _ (p1 : 'label_ipatt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ _ (p1 : 'label_ipatt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_ipatt_list) _ + (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : + 'label_ipatt_list)))) ]) ])) + ()); + Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) _ (i : 'label_longident) + (_loc : Gram.Loc.t) -> + (Ast.PaEq (_loc, i, p) : 'label_ipatt)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.patt_tag : + 'label_ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt;" n s)) : + 'label_ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), + s) -> + (Ast.PaAnt (_loc, + (mk_anti ~c: "patt" n s)) : + 'label_ipatt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (type_declaration : 'type_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); + Gram.Slist0 + (Gram.Snterm + (Gram.Entry.obj + (constrain : 'constrain Gram.Entry.t))) ], + (Gram.Action.mk + (fun (cl : 'constrain list) + (tk : 'opt_eq_ctyp) + ((n, tpl) : 'type_ident_and_parameters) + (_loc : Gram.Loc.t) -> + (Ast.TyDcl (_loc, n, tpl, tk, cl) : + 'type_declaration)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'type_declaration) _ + (t1 : 'type_declaration) + (_loc : Gram.Loc.t) -> + (Ast.TyAnd (_loc, t1, t2) : + 'type_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'type_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctypand" n s)) : + 'type_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'type_declaration) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (constrain : 'constrain Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "constraint"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Gram.Loc.t) -> + ((t1, t2) : 'constrain)))) ]) ])) + ()); + Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.TyNil _loc : 'opt_eq_ctyp)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (type_kind : 'type_kind Gram.Entry.t)) ], + (Gram.Action.mk + (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) + -> (tk : 'opt_eq_ctyp)))) ]) ])) + ()); + Gram.extend (type_kind : 'type_kind Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'type_kind)))) ]) ])) + ()); + Gram.extend + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Slist0 + (Gram.Snterm + (Gram.Entry.obj + (optional_type_parameter : + 'optional_type_parameter Gram.Entry.t))) ], + (Gram.Action.mk + (fun (tpl : 'optional_type_parameter list) + (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) + ()); + Gram.extend + (type_longident_and_parameters : + 'type_longident_and_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (type_parameters : + 'type_parameters Gram.Entry.t)) ], + (Gram.Action.mk + (fun (tpl : 'type_parameters) + (i : 'type_longident) (_loc : Gram.Loc.t) + -> + (tpl (Ast.TyId (_loc, i)) : + 'type_longident_and_parameters)))) ]) ])) + ()); + Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (fun t -> t : 'type_parameters)))); + ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_parameter) (_loc : Gram.Loc.t) + -> + (fun acc -> Ast.TyApp (_loc, acc, t) : + 'type_parameters)))); + ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'type_parameters) + (t1 : 'type_parameter) (_loc : Gram.Loc.t) + -> + (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : + 'type_parameters)))) ]) ])) + ()); + Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> + (Ast.TyQuM (_loc, i) : 'type_parameter)))); + ([ Gram.Skeyword "+"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> + (Ast.TyQuP (_loc, i) : 'type_parameter)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyQuo (_loc, i) : 'type_parameter)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'type_parameter) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.TyAnt (_loc, (mk_anti n s)) : + 'type_parameter) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (optional_type_parameter : + 'optional_type_parameter Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.TyAny _loc : 'optional_type_parameter)))); + ([ Gram.Skeyword "-"; Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.TyAnM _loc : 'optional_type_parameter)))); + ([ Gram.Skeyword "+"; Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.TyAnP _loc : 'optional_type_parameter)))); + ([ Gram.Skeyword "-"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> + (Ast.TyQuM (_loc, i) : + 'optional_type_parameter)))); + ([ Gram.Skeyword "+"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> + (Ast.TyQuP (_loc, i) : + 'optional_type_parameter)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyQuo (_loc, i) : + 'optional_type_parameter)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'optional_type_parameter) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.TyAnt (_loc, (mk_anti n s)) : + 'optional_type_parameter) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (ctyp : 'ctyp Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "private"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "private"; + Gram.Snterml + ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)), + "alias") ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) -> + (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); + ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "!"; + Gram.Snterm + (Gram.Entry.obj + (typevars : 'typevars Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ + (_loc : Gram.Loc.t) -> + (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) (i : 'a_OPTLABEL) + (_loc : Gram.Loc.t) -> + (Ast.TyOlb (_loc, i, t) : 'ctyp)))); + ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.TyOlb (_loc, i, t) : 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LABEL : 'a_LABEL Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) (i : 'a_LABEL) + (_loc : Gram.Loc.t) -> + (Ast.TyLab (_loc, i, t) : 'ctyp)))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) (t1 : 'ctyp) + (_loc : Gram.Loc.t) -> + (let t = Ast.TyApp (_loc, t1, t2) + in + try + Ast.TyId (_loc, (Ast.ident_of_ctyp t)) + with | Invalid_argument _ -> t : + 'ctyp)))) ]); + ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) + (_loc : Gram.Loc.t) -> + (try + Ast.TyId (_loc, + (Ast.IdAcc (_loc, + (Ast.ident_of_ctyp t1), + (Ast.ident_of_ctyp t2)))) + with + | Invalid_argument s -> + raise (Stream.Error s) : + 'ctyp)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (package_type : + 'package_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'package_type) _ _ + (_loc : Gram.Loc.t) -> + (Ast.TyPkg (_loc, p) : 'ctyp)))); + ([ Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (opt_meth_list : + 'opt_meth_list Gram.Entry.t)); + Gram.Skeyword ">" ], + (Gram.Action.mk + (fun _ (t : 'opt_meth_list) _ + (_loc : Gram.Loc.t) -> (t : 'ctyp)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_longident) _ + (_loc : Gram.Loc.t) -> + (Ast.TyCls (_loc, i) : 'ctyp)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (t : 'label_declaration_list) _ + (_loc : Gram.Loc.t) -> + (Ast.TyRec (_loc, t) : 'ctyp)))); + ([ Gram.Skeyword "[<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (name_tags : 'name_tags Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) + _ (_loc : Gram.Loc.t) -> + (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); + ([ Gram.Skeyword "[<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ + (_loc : Gram.Loc.t) -> + (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (name_tags : 'name_tags Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) + _ _ (_loc : Gram.Loc.t) -> + (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ + (_loc : Gram.Loc.t) -> + (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ + (_loc : Gram.Loc.t) -> + (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword ">"; + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ _ (_loc : Gram.Loc.t) -> + (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) : + 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ + (_loc : Gram.Loc.t) -> + (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (constructor_declarations : + 'constructor_declarations Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'constructor_declarations) _ + (_loc : Gram.Loc.t) -> + (Ast.TySum (_loc, t) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.TySum (_loc, (Ast.TyNil _loc)) : + 'ctyp)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> + (t : 'ctyp)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword "*"; + Gram.Snterm + (Gram.Entry.obj + (star_ctyp : 'star_ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ + (_loc : Gram.Loc.t) -> + (Ast.TyTup (_loc, + (Ast.TySta (_loc, t, tl))) : + 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) : + 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : + 'ctyp)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("id", _) -> true + | _ -> false), + "ANTIQUOT (\"id\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("id" as n)), s) -> + (Ast.TyId (_loc, + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)))) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.TyTup (_loc, + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)))) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), + s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.TyAny _loc : 'ctyp)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) + ()); + Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'star_ctyp)))); + ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp*" n s)) : + 'star_ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'star_ctyp) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (constructor_declarations : + 'constructor_declarations Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : + 'constructor_declarations)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (s : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (let (tl, rt) = generalized_type_of_type t + in + Ast.TyCol (_loc, + (Ast.TyId (_loc, + (Ast.IdUid (_loc, s)))), + (Ast.TyArr (_loc, + (Ast.tyAnd_of_list tl), rt))) : + 'constructor_declarations)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_arg_list) _ + (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyOf (_loc, + (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), + t) : + 'constructor_declarations)))); + ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'constructor_declarations) _ + (t1 : 'constructor_declarations) + (_loc : Gram.Loc.t) -> + (Ast.TyOr (_loc, t1, t2) : + 'constructor_declarations)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'constructor_declarations) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp|" n s)) : + 'constructor_declarations) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'constructor_declarations) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (constructor_declaration : + 'constructor_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : + 'constructor_declaration)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_arg_list) _ + (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.TyOf (_loc, + (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), + t) : + 'constructor_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'constructor_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'constructor_declaration) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'constructor_arg_list)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'constructor_arg_list) _ + (t1 : 'constructor_arg_list) + (_loc : Gram.Loc.t) -> + (Ast.TyAnd (_loc, t1, t2) : + 'constructor_arg_list)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctypand" n s)) : + 'constructor_arg_list) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (label_declaration_list : + 'label_declaration_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t1 : 'label_declaration) + (_loc : Gram.Loc.t) -> + (t1 : 'label_declaration_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (t1 : 'label_declaration) + (_loc : Gram.Loc.t) -> + (t1 : 'label_declaration_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'label_declaration_list) _ + (t1 : 'label_declaration) + (_loc : Gram.Loc.t) -> + (Ast.TySem (_loc, t1, t2) : + 'label_declaration_list)))) ]) ])) + ()); + Gram.extend + (label_declaration : 'label_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Skeyword "mutable"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) + (_loc : Gram.Loc.t) -> + (Ast.TyCol (_loc, + (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), + (Ast.TyMut (_loc, t))) : + 'label_declaration)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (s : 'a_LIDENT) + (_loc : Gram.Loc.t) -> + (Ast.TyCol (_loc, + (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), + t) : + 'label_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'label_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp;" n s)) : + 'label_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'label_declaration) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_ident : 'a_ident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (i : 'a_ident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (i : 'a_ident)))) ]) ])) + ()); + Gram.extend (ident : 'ident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident) _ (i : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) : + 'ident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (i : 'ident) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAcc (_loc, + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s))), + i) : + 'ident) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdLid (_loc, i) : 'ident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdUid (_loc, i) : 'ident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'ident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_longident : 'module_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdUid (_loc, i) : 'module_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (l : 'module_longident) _ (m : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : + 'module_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'module_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "apply"), None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'module_longident_with_app) + (i : 'module_longident_with_app) + (_loc : Gram.Loc.t) -> + (Ast.IdApp (_loc, i, j) : + 'module_longident_with_app)))) ]); + ((Some "."), None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'module_longident_with_app) _ + (i : 'module_longident_with_app) + (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, i, j) : + 'module_longident_with_app)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'module_longident_with_app) _ + (_loc : Gram.Loc.t) -> + (i : 'module_longident_with_app)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdUid (_loc, i) : + 'module_longident_with_app)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'module_longident_with_app) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_longident_dot_lparen : + 'module_longident_dot_lparen Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Skeyword "(" ], + (Gram.Action.mk + (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) + -> + (Ast.IdUid (_loc, i) : + 'module_longident_dot_lparen)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (l : 'module_longident_dot_lparen) _ + (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : + 'module_longident_dot_lparen)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); + Gram.Skeyword "."; Gram.Skeyword "(" ], + (Gram.Action.mk + (fun _ _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'module_longident_dot_lparen) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (type_longident : 'type_longident Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "apply"), None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'type_longident) + (i : 'type_longident) (_loc : Gram.Loc.t) + -> + (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); + ((Some "."), None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'type_longident) _ + (i : 'type_longident) (_loc : Gram.Loc.t) + -> + (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'type_longident) _ + (_loc : Gram.Loc.t) -> + (i : 'type_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdUid (_loc, i) : 'type_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdLid (_loc, i) : 'type_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'type_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (label_longident : 'label_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdLid (_loc, i) : 'label_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (l : 'label_longident) _ (m : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : + 'label_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'label_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_type_longident : 'class_type_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'type_longident) (_loc : Gram.Loc.t) + -> (x : 'class_type_longident)))) ]) ])) + ()); + Gram.extend (val_longident : 'val_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'ident) (_loc : Gram.Loc.t) -> + (x : 'val_longident)))) ]) ])) + ()); + Gram.extend (class_longident : 'class_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'label_longident) + (_loc : Gram.Loc.t) -> + (x : 'class_longident)))) ]) ])) + ()); + Gram.extend + (class_declaration : 'class_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_fun_binding : + 'class_fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_fun_binding) + (ci : 'class_info_for_class_expr) + (_loc : Gram.Loc.t) -> + (Ast.CeEq (_loc, ci, ce) : + 'class_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_expr_tag : + 'class_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "cdcl" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cdcl" | "anti" | "list" as n)), + s) -> + (Ast.CeAnt (_loc, + (mk_anti ~c: "class_expr" n s)) : + 'class_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (c2 : 'class_declaration) _ + (c1 : 'class_declaration) + (_loc : Gram.Loc.t) -> + (Ast.CeAnd (_loc, c1, c2) : + 'class_declaration)))) ]) ])) + ()); + Gram.extend + (class_fun_binding : 'class_fun_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (cfb : 'class_fun_binding) + (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> + (Ast.CeFun (_loc, p, cfb) : + 'class_fun_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ + (ct : 'class_type_plus) _ + (_loc : Gram.Loc.t) -> + (Ast.CeTyc (_loc, ce, ct) : + 'class_fun_binding)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) + -> (ce : 'class_fun_binding)))) ]) ])) + ()); + Gram.extend + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) + (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> + (Ast.CtCon (_loc, mv, + (Ast.IdLid (_loc, i)), ot) : + 'class_info_for_class_type)))) ]) ])) + ()); + Gram.extend + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) + (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> + (Ast.CeCon (_loc, mv, + (Ast.IdLid (_loc, i)), ot) : + 'class_info_for_class_expr)))) ]) ])) + ()); + Gram.extend + (class_name_and_param : 'class_name_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + ((i, (Ast.TyNil _loc)) : + 'class_name_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_type_parameter : + 'comma_type_parameter Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (x : 'comma_type_parameter) _ + (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + ((i, x) : 'class_name_and_param)))) ]) ])) + ()); + Gram.extend + (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_parameter) (_loc : Gram.Loc.t) + -> (t : 'comma_type_parameter)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp," n s)) : + 'comma_type_parameter) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'comma_type_parameter) _ + (t1 : 'comma_type_parameter) + (_loc : Gram.Loc.t) -> + (Ast.TyCom (_loc, t1, t2) : + 'comma_type_parameter)))) ]) ])) + ()); + Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.TyNil _loc : 'opt_comma_ctyp)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t) + -> (x : 'opt_comma_ctyp)))) ]) ])) + ()); + Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'comma_ctyp)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp," n s)) : + 'comma_ctyp) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) + ()); + Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) + -> (ce : 'class_fun_def)))); + ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (ce : 'class_fun_def) + (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> + (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) + ()); + Gram.extend (class_expr : 'class_expr Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (bi : 'binding) + (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> + (Ast.CeLet (_loc, rf, bi, ce) : + 'class_expr)))); + ([ Gram.Skeyword "fun"; + Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_fun_def : + 'class_fun_def Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_fun_def) + (p : 'labeled_ipatt) _ (_loc : Gram.Loc.t) + -> (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; + Gram.Snterml + ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), + "label") ], + (Gram.Action.mk + (fun (e : 'expr) (ce : 'class_expr) + (_loc : Gram.Loc.t) -> + (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (ce : 'class_expr) _ + (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (ct : 'class_type) _ (ce : 'class_expr) + _ (_loc : Gram.Loc.t) -> + (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); + ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_patt : + 'opt_class_self_patt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_structure : + 'class_structure Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (cst : 'class_structure) + (csp : 'opt_class_self_patt) _ + (_loc : Gram.Loc.t) -> + (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_longident_and_param) + (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_expr_tag : + 'class_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "cexp" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "cexp" | "anti" as n)), + s) -> + (Ast.CeAnt (_loc, + (mk_anti ~c: "class_expr" n s)) : + 'class_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ci : 'class_longident) + (_loc : Gram.Loc.t) -> + (Ast.CeCon (_loc, Ast.ViNil, ci, + (Ast.TyNil _loc)) : + 'class_longident_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'comma_ctyp) _ + (ci : 'class_longident) (_loc : Gram.Loc.t) + -> + (Ast.CeCon (_loc, Ast.ViNil, ci, t) : + 'class_longident_and_param)))) ]) ])) + ()); + Gram.extend (class_structure : 'class_structure Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules class_structure + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (cst : 'class_str_item) + (_loc : Gram.Loc.t) -> + (cst : 'e__10)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__10 list) (_loc : Gram.Loc.t) -> + (Ast.crSem_of_list l : 'class_structure)))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "cst" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (cst : 'class_structure) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cst" | "anti" | "list" as n)), + s) -> + (Ast.CrSem (_loc, + (Ast.CrAnt (_loc, + (mk_anti ~c: "class_str_item" n s))), + cst) : + 'class_structure) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "cst" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cst" | "anti" | "list" as n)), + s) -> + (Ast.CrAnt (_loc, + (mk_anti ~c: "class_str_item" n s)) : + 'class_structure) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.PaNil _loc : 'opt_class_self_patt)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, p, t) : + 'opt_class_self_patt)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> + (p : 'opt_class_self_patt)))) ]) ])) + ()); + Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "initializer"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (se : 'expr) _ (_loc : Gram.Loc.t) -> + (Ast.CrIni (_loc, se) : 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (type_constraint : + 'type_constraint Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Gram.Loc.t) -> + (Ast.CrCtr (_loc, t1, t2) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (method_opt_override : + 'method_opt_override Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) _ + (pf : 'opt_private) + (o : 'method_opt_override) + (_loc : Gram.Loc.t) -> + (if o <> Ast.OvNil + then + raise + (Stream.Error + "override (!) is incompatible with virtual") + else Ast.CrVir (_loc, l, pf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (method_opt_override : + 'method_opt_override Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_polyt : 'opt_polyt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (topt : 'opt_polyt) + (l : 'label) (pf : 'opt_private) + (o : 'method_opt_override) + (_loc : Gram.Loc.t) -> + (Ast.CrMth (_loc, l, o, pf, e, topt) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (method_opt_override : + 'method_opt_override Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ + (o : 'method_opt_override) + (_loc : Gram.Loc.t) -> + (if o <> Ast.OvNil + then + raise + (Stream.Error + "override (!) is incompatible with virtual") + else Ast.CrVir (_loc, l, pf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val_opt_override : + 'value_val_opt_override Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (mf : 'opt_mutable) _ + (o : 'value_val_opt_override) + (_loc : Gram.Loc.t) -> + (if o <> Ast.OvNil + then + raise + (Stream.Error + "override (!) is incompatible with virtual") + else Ast.CrVvr (_loc, l, mf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val_opt_override : + 'value_val_opt_override Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) _ + (mf : 'opt_mutable) + (o : 'value_val_opt_override) + (_loc : Gram.Loc.t) -> + (if o <> Ast.OvNil + then + raise + (Stream.Error + "override (!) is incompatible with virtual") + else Ast.CrVvr (_loc, l, mf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val_opt_override : + 'value_val_opt_override Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (cvalue_binding : + 'cvalue_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'cvalue_binding) (lab : 'label) + (mf : 'opt_mutable) + (o : 'value_val_opt_override) + (_loc : Gram.Loc.t) -> + (Ast.CrVal (_loc, lab, o, mf, e) : + 'class_str_item)))); + ([ Gram.Skeyword "inherit"; + Gram.Snterm + (Gram.Entry.obj + (opt_override : + 'opt_override Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_as_lident : + 'opt_as_lident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (pb : 'opt_as_lident) (ce : 'class_expr) + (o : 'opt_override) _ (_loc : Gram.Loc.t) + -> + (Ast.CrInh (_loc, o, ce, pb) : + 'class_str_item)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_str_item_tag : + 'class_str_item) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "cst" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cst" | "anti" | "list" as n)), + s) -> + (Ast.CrAnt (_loc, + (mk_anti ~c: "class_str_item" n s)) : + 'class_str_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (method_opt_override : 'method_opt_override Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "method" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.OvNil : 'method_opt_override)))); + ([ Gram.Skeyword "method"; + Gram.Stoken + (((function + | ANTIQUOT (("!" | "override" | "anti"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("!" | "override" | "anti" as n)), s) + -> + (Ast.OvAnt (mk_anti n s) : + 'method_opt_override) + | _ -> assert false))); + ([ Gram.Skeyword "method"; Gram.Skeyword "!" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.OvOverride : 'method_opt_override)))) ]) ])) + ()); + Gram.extend + (value_val_opt_override : + 'value_val_opt_override Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.OvNil : 'value_val_opt_override)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Stoken + (((function + | ANTIQUOT (("!" | "override" | "anti"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("!" | "override" | "anti" as n)), s) + -> + (Ast.OvAnt (mk_anti n s) : + 'value_val_opt_override) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Skeyword "!" ], + (Gram.Action.mk + (fun _ _ (_loc : Gram.Loc.t) -> + (Ast.OvOverride : 'value_val_opt_override)))) ]) ])) + ()); + Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + ("" : 'opt_as_lident)))); + ([ Gram.Skeyword "as"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> + (i : 'opt_as_lident)))) ]) ])) + ()); + Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.TyNil _loc : 'opt_polyt)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) -> + (t : 'opt_polyt)))) ]) ])) + ()); + Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'ctyp) _ + (_loc : Gram.Loc.t) -> + (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : + 'cvalue_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)); + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t2 : 'ctyp) _ + (t : 'poly_type) _ (_loc : Gram.Loc.t) -> + (match t with + | Ast.TyPol (_, _, _) -> + raise + (Stream.Error + "unexpected polytype here") + | _ -> Ast.ExCoe (_loc, e, t, t2) : + 'cvalue_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'poly_type) _ + (_loc : Gram.Loc.t) -> + (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); + ([ Gram.Skeyword ":"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (unquoted_typevars : + 'unquoted_typevars Gram.Entry.t)); + Gram.Skeyword "."; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t2 : 'ctyp) _ + (t1 : 'unquoted_typevars) _ _ + (_loc : Gram.Loc.t) -> + (let u = Ast.TyTypePol (_loc, t1, t2) + in Ast.ExTyc (_loc, e, u) : + 'cvalue_binding)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (e : 'cvalue_binding)))) ]) ])) + ()); + Gram.extend (label : 'label Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (i : 'label)))) ]) ])) + ()); + Gram.extend (class_type : 'class_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_type : + 'opt_class_self_type Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_signature : + 'class_signature Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (csg : 'class_signature) + (cst : 'opt_class_self_type) _ + (_loc : Gram.Loc.t) -> + (Ast.CtSig (_loc, cst, csg) : 'class_type)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident_and_param : + 'class_type_longident_and_param Gram. + Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type_longident_and_param) + (_loc : Gram.Loc.t) -> (ct : 'class_type)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_type_tag : + 'class_type) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "ctyp" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "ctyp" | "anti" as n)), + s) -> + (Ast.CtAnt (_loc, + (mk_anti ~c: "class_type" n s)) : + 'class_type) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_type_longident_and_param : + 'class_type_longident_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident : + 'class_type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_type_longident) + (_loc : Gram.Loc.t) -> + (Ast.CtCon (_loc, Ast.ViNil, i, + (Ast.TyNil _loc)) : + 'class_type_longident_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident : + 'class_type_longident Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'comma_ctyp) _ + (i : 'class_type_longident) + (_loc : Gram.Loc.t) -> + (Ast.CtCon (_loc, Ast.ViNil, i, t) : + 'class_type_longident_and_param)))) ]) ])) + ()); + Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type) (_loc : Gram.Loc.t) -> + (ct : 'class_type_plus)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "]"; Gram.Skeyword "->"; Gram. + Sself ], + (Gram.Action.mk + (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ + (_loc : Gram.Loc.t) -> + (Ast.CtFun (_loc, t, ct) : + 'class_type_plus)))) ]) ])) + ()); + Gram.extend + (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.TyNil _loc : 'opt_class_self_type)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> + (t : 'opt_class_self_type)))) ]) ])) + ()); + Gram.extend (class_signature : 'class_signature Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules class_signature + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (csg : 'class_sig_item) + (_loc : Gram.Loc.t) -> + (csg : 'e__11)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__11 list) (_loc : Gram.Loc.t) -> + (Ast.cgSem_of_list l : 'class_signature)))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "csg" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (csg : 'class_signature) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "csg" | "anti" | "list" as n)), + s) -> + (Ast.CgSem (_loc, + (Ast.CgAnt (_loc, + (mk_anti ~c: "class_sig_item" n s))), + csg) : + 'class_signature) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "csg" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "csg" | "anti" | "list" as n)), + s) -> + (Ast.CgAnt (_loc, + (mk_anti ~c: "class_sig_item" n s)) : + 'class_signature) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_constraint : + 'type_constraint Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Gram.Loc.t) -> + (Ast.CgCtr (_loc, t1, t2) : + 'class_sig_item)))); + ([ Gram.Skeyword "method"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) _ + (pf : 'opt_private) _ (_loc : Gram.Loc.t) + -> + (Ast.CgVir (_loc, l, pf, t) : + 'class_sig_item)))); + ([ Gram.Skeyword "method"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ (_loc : Gram.Loc.t) + -> + (Ast.CgMth (_loc, l, pf, t) : + 'class_sig_item)))); + ([ Gram.Skeyword "method"; + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ _ (_loc : Gram.Loc.t) + -> + (Ast.CgVir (_loc, l, pf, t) : + 'class_sig_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (l : 'label) + (mv : 'opt_virtual) (mf : 'opt_mutable) _ + (_loc : Gram.Loc.t) -> + (Ast.CgVal (_loc, l, mf, mv, t) : + 'class_sig_item)))); + ([ Gram.Skeyword "inherit"; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) + -> (Ast.CgInh (_loc, cs) : 'class_sig_item)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_sig_item_tag : + 'class_sig_item) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "csg" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "csg" | "anti" | "list" as n)), + s) -> + (Ast.CgAnt (_loc, + (mk_anti ~c: "class_sig_item" n s)) : + 'class_sig_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "constraint" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (() : 'type_constraint)))); + ([ Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (() : 'type_constraint)))) ]) ])) + ()); + Gram.extend + (class_description : 'class_description Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type_plus) _ + (ci : 'class_info_for_class_type) + (_loc : Gram.Loc.t) -> + (Ast.CtCol (_loc, ci, ct) : + 'class_description)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_type_tag : + 'class_description) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "typ" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "typ" | "anti" | "list" as n)), + s) -> + (Ast.CtAnt (_loc, + (mk_anti ~c: "class_type" n s)) : + 'class_description) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (cd2 : 'class_description) _ + (cd1 : 'class_description) + (_loc : Gram.Loc.t) -> + (Ast.CtAnd (_loc, cd1, cd2) : + 'class_description)))) ]) ])) + ()); + Gram.extend + (class_type_declaration : + 'class_type_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type) _ + (ci : 'class_info_for_class_type) + (_loc : Gram.Loc.t) -> + (Ast.CtEq (_loc, ci, ct) : + 'class_type_declaration)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.class_type_tag : + 'class_type_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "typ" | "anti" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "typ" | "anti" | "list" as n)), + s) -> + (Ast.CtAnt (_loc, + (mk_anti ~c: "class_type" n s)) : + 'class_type_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (cd2 : 'class_type_declaration) _ + (cd1 : 'class_type_declaration) + (_loc : Gram.Loc.t) -> + (Ast.CtAnd (_loc, cd1, cd2) : + 'class_type_declaration)))) ]) ])) + ()); + Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> + (b1 : 'field_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) + -> (b1 : 'field_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'field_expr_list) _ + (b1 : 'field_expr) (_loc : Gram.Loc.t) -> + (Ast.RbSem (_loc, b1, b2) : + 'field_expr_list)))) ]) ])) + ()); + Gram.extend (field_expr : 'field_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterml + ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), + "top") ], + (Gram.Action.mk + (fun (e : 'expr) _ (l : 'label) + (_loc : Gram.Loc.t) -> + (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) : + 'field_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.RbAnt (_loc, + (mk_anti ~c: "rec_binding" n s)) : + 'field_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "bi" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "bi" | "anti" as n)), s) + -> + (Ast.RbAnt (_loc, + (mk_anti ~c: "rec_binding" n s)) : + 'field_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (meth_list : 'meth_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (v : 'opt_dot_dot) (m : 'meth_decl) + (_loc : Gram.Loc.t) -> + ((m, v) : 'meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) + (_loc : Gram.Loc.t) -> + ((m, v) : 'meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) + (_loc : Gram.Loc.t) -> + (((Ast.TySem (_loc, m, ml)), v) : + 'meth_list)))) ]) ])) + ()); + Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (lab : 'a_LIDENT) + (_loc : Gram.Loc.t) -> + (Ast.TyCol (_loc, + (Ast.TyId (_loc, + (Ast.IdLid (_loc, lab)))), + t) : + 'meth_decl)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'meth_decl) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp;" n s)) : + 'meth_decl) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'meth_decl) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> + (Ast.TyObj (_loc, (Ast.TyNil _loc), v) : + 'opt_meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_list : 'meth_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((ml, v) : 'meth_list) + (_loc : Gram.Loc.t) -> + (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) + ()); + Gram.extend (poly_type : 'poly_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'poly_type)))) ]) ])) + ()); + Gram.extend (package_type : 'package_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'module_type) (_loc : Gram.Loc.t) -> + (p : 'package_type)))) ]) ])) + ()); + Gram.extend (typevars : 'typevars Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyQuo (_loc, i) : 'typevars)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'typevars) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'typevars) + | _ -> assert false))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'typevars) (t1 : 'typevars) + (_loc : Gram.Loc.t) -> + (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) + ()); + Gram.extend + (unquoted_typevars : 'unquoted_typevars Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) (_loc : Gram.Loc.t) -> + (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : + 'unquoted_typevars)))); + ([ Gram.Stoken + (((function + | QUOTATION _ -> true + | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand _loc x Quotation. + DynAst.ctyp_tag : + 'unquoted_typevars) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'unquoted_typevars) + | _ -> assert false))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'unquoted_typevars) + (t1 : 'unquoted_typevars) + (_loc : Gram.Loc.t) -> + (Ast.TyApp (_loc, t1, t2) : + 'unquoted_typevars)))) ]) ])) + ()); + Gram.extend (row_field : 'row_field Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ + (_loc : Gram.Loc.t) -> + (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) : + 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "of"; Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ + (_loc : Gram.Loc.t) -> + (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), + t) : + 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyVrn (_loc, i) : 'row_field)))); + ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'row_field) _ (t1 : 'row_field) + (_loc : Gram.Loc.t) -> + (Ast.TyOr (_loc, t1, t2) : 'row_field)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp|" n s)) : + 'row_field) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'row_field) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> + (t : 'amp_ctyp)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp&" n s)) : + 'amp_ctyp) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) + ()); + Gram.extend (name_tags : 'name_tags Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyVrn (_loc, i) : 'name_tags)))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'name_tags) (t1 : 'name_tags) + (_loc : Gram.Loc.t) -> + (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, + (mk_anti ~c: "ctyp" n s)) : + 'name_tags) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (fun i p -> Ast.PaOlb (_loc, i, p) : + 'eq_expr)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> + (fun i p -> Ast.PaOlbi (_loc, i, p, e) : + 'eq_expr)))) ]) ])) + ()); + Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Gram.Loc.t) -> + (p : 'patt_tcon)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (p : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) + ()); + Gram.extend (ipatt : 'ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ + (_loc : Gram.Loc.t) -> + (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); + ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'ipatt_tcon) _ _ + (_loc : Gram.Loc.t) -> + (Ast.PaOlb (_loc, "", p) : 'ipatt)))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaOlb (_loc, (mk_anti n i), + (Ast.PaNil _loc)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ + (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (f (mk_anti n i) p : 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> (f i p : 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, (mk_anti n i), + (Ast.PaNil _loc)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'ipatt) _ + (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, (mk_anti n i), p) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LABEL i -> + (Ast.PaLab (_loc, i, p) : 'ipatt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> + (p : 'ipatt_tcon)))); + ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (p : 'ipatt) + (_loc : Gram.Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) + ()); + Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | ANTIQUOT (("to" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"to\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("to" | "anti" as n)), s) -> + (Ast.DiAnt (mk_anti n s) : + 'direction_flag) + | _ -> assert false))); + ([ Gram.Skeyword "downto" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.DiDownto : 'direction_flag)))); + ([ Gram.Skeyword "to" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.DiTo : 'direction_flag)))) ]) ])) + ()); + Gram.extend (opt_private : 'opt_private Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.PrNil : 'opt_private)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("private" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"private\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("private" | "anti" as n)), s) + -> + (Ast.PrAnt (mk_anti n s) : + 'opt_private) + | _ -> assert false))); + ([ Gram.Skeyword "private" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.PrPrivate : 'opt_private)))) ]) ])) + ()); + Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.MuNil : 'opt_mutable)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("mutable" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("mutable" | "anti" as n)), s) + -> + (Ast.MuAnt (mk_anti n s) : + 'opt_mutable) + | _ -> assert false))); + ([ Gram.Skeyword "mutable" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.MuMutable : 'opt_mutable)))) ]) ])) + ()); + Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.ViNil : 'opt_virtual)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("virtual" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" | "anti" as n)), s) + -> + (Ast.ViAnt (mk_anti n s) : + 'opt_virtual) + | _ -> assert false))); + ([ Gram.Skeyword "virtual" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.ViVirtual : 'opt_virtual)))) ]) ])) + ()); + Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.RvNil : 'opt_dot_dot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ((".." | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"..\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT (((".." | "anti" as n)), s) -> + (Ast.RvAnt (mk_anti n s) : + 'opt_dot_dot) + | _ -> assert false))); + ([ Gram.Skeyword ".." ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.RvRowVar : 'opt_dot_dot)))) ]) ])) + ()); + Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.ReNil : 'opt_rec)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("rec" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("rec" | "anti" as n)), s) -> + (Ast.ReAnt (mk_anti n s) : 'opt_rec) + | _ -> assert false))); + ([ Gram.Skeyword "rec" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.ReRecursive : 'opt_rec)))) ]) ])) + ()); + Gram.extend (opt_override : 'opt_override Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.OvNil : 'opt_override)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("!" | "override" | "anti"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("!" | "override" | "anti" as n)), s) + -> + (Ast.OvAnt (mk_anti n s) : + 'opt_override) + | _ -> assert false))); + ([ Gram.Skeyword "!" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (Ast.OvOverride : 'opt_override)))) ]) ])) + ()); + Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.ExNil _loc : 'opt_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Gram.Loc.t) -> + (e : 'opt_expr)))) ]) ])) + ()); + Gram.extend (interf : 'interf Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (([], None) : 'interf) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'interf) _ + (si : 'sig_item) (_loc : Gram.Loc.t) -> + (((si :: sil), stopped) : 'interf)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (([ Ast.SgDir (_loc, n, dp) ], + (stopped_at _loc)) : 'interf)))) ]) ])) + ()); + Gram.extend (sig_items : 'sig_items Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules sig_items + [ ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : + 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (sg : 'sig_item) + (_loc : Gram.Loc.t) -> + (sg : 'e__12)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__12 list) (_loc : Gram.Loc.t) -> + (Ast.sgSem_of_list l : 'sig_items)))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "sigi" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (sg : 'sig_items) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "sigi" | "anti" | "list" as n)), + s) -> + (Ast.SgSem (_loc, + (Ast.SgAnt (_loc, + (mk_anti n ~c: "sig_item" s))), + sg) : + 'sig_items) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "sigi" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "sigi" | "anti" | "list" as n)), + s) -> + (Ast.SgAnt (_loc, + (mk_anti n ~c: "sig_item" s)) : + 'sig_items) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (implem : 'implem Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (([], None) : 'implem) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'implem) _ + (si : 'str_item) (_loc : Gram.Loc.t) -> + (((si :: sil), stopped) : 'implem)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (([ Ast.StDir (_loc, n, dp) ], + (stopped_at _loc)) : 'implem)))) ]) ])) + ()); + Gram.extend (str_items : 'str_items Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules str_items + [ ([ Gram.Snterm + (Gram.Entry.obj + (str_item : + 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_item) + (_loc : Gram.Loc.t) -> + (st : 'e__13)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__13 list) (_loc : Gram.Loc.t) -> + (Ast.stSem_of_list l : 'str_items)))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "stri" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (st : 'str_items) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "stri" | "anti" | "list" as n)), + s) -> + (Ast.StSem (_loc, + (Ast.StAnt (_loc, + (mk_anti n ~c: "str_item" s))), + st) : + 'str_items) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "stri" | "anti" | "list"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "stri" | "anti" | "list" as n)), + s) -> + (Ast.StAnt (_loc, + (mk_anti n ~c: "str_item" s)) : + 'str_items) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (None : 'top_phrase) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (phrase : 'phrase Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ph : 'phrase) (_loc : Gram.Loc.t) -> + (Some ph : 'top_phrase)))) ]) ])) + ()); + Gram.extend (use_file : 'use_file Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (([], None) : 'use_file) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'use_file) _ + (si : 'str_item) (_loc : Gram.Loc.t) -> + (((si :: sil), stopped) : 'use_file)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (([ Ast.StDir (_loc, n, dp) ], + (stopped_at _loc)) : 'use_file)))) ]) ])) + ()); + Gram.extend (phrase : 'phrase Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> + (st : 'phrase)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) + ()); + Gram.extend (a_INT : 'a_INT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | INT (_, _) -> true | _ -> false), + "INT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | INT (_, s) -> (s : 'a_INT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int" | "`int"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "int" | "`int" as n)), + s) -> (mk_anti n s : 'a_INT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | INT32 (_, _) -> true + | _ -> false), + "INT32 (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | INT32 (_, s) -> (s : 'a_INT32) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int32" | "`int32"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "int32" | "`int32" as n)), s) + -> (mk_anti n s : 'a_INT32) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | INT64 (_, _) -> true + | _ -> false), + "INT64 (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | INT64 (_, s) -> (s : 'a_INT64) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int64" | "`int64"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "int64" | "`int64" as n)), s) + -> (mk_anti n s : 'a_INT64) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | NATIVEINT (_, _) -> true + | _ -> false), + "NATIVEINT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "nativeint" | "`nativeint"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "nativeint" | "`nativeint" as + n)), + s) -> (mk_anti n s : 'a_NATIVEINT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | FLOAT (_, _) -> true + | _ -> false), + "FLOAT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | FLOAT (_, s) -> (s : 'a_FLOAT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "flo" | "`flo"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "flo" | "`flo" as n)), + s) -> (mk_anti n s : 'a_FLOAT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | CHAR (_, _) -> true + | _ -> false), + "CHAR (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | CHAR (_, s) -> (s : 'a_CHAR) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "chr" | "`chr"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "chr" | "`chr" as n)), + s) -> (mk_anti n s : 'a_CHAR) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | UIDENT _ -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | UIDENT s -> (s : 'a_UIDENT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "uid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"uid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "uid" as n)), s) -> + (mk_anti n s : 'a_UIDENT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LIDENT s -> (s : 'a_LIDENT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), s) -> + (mk_anti n s : 'a_LIDENT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | LABEL s -> (s : 'a_LABEL) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":" ], + (Gram.Action.mk + (fun _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (mk_anti n s : 'a_LABEL) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | OPTLABEL s -> (s : 'a_OPTLABEL) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":" ], + (Gram.Action.mk + (fun _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (mk_anti n s : 'a_OPTLABEL) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | STRING (_, s) -> (s : 'a_STRING) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "str" | "`str"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "str" | "`str" as n)), + s) -> (mk_anti n s : 'a_STRING) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (string_list : 'string_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | STRING (_, x) -> + (Ast.LCons (x, Ast.LNil) : + 'string_list) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")); + Gram.Sself ], + (Gram.Action.mk + (fun (xs : 'string_list) + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | STRING (_, x) -> + (Ast.LCons (x, xs) : 'string_list) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "str_list"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT (("" | "str_list"), s) -> + (Ast.LAnt (mk_anti "str_list" s) : + 'string_list) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (value_let : 'value_let Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "value" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (() : 'value_let)))) ]) ])) + ()); + Gram.extend (value_val : 'value_val Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "value" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> + (() : 'value_val)))) ]) ])) + ()); + Gram.extend (semi : 'semi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ])) + ()); + Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.ExNil _loc : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Gram.Loc.t) -> + (e : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sem_expr : 'sem_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e2 : 'sem_expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e2 : 'comma_expr) _ (e1 : 'expr) + (_loc : Gram.Loc.t) -> + (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) + ()); + Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.PaNil _loc : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'patt) (_loc : Gram.Loc.t) -> + (x : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'patt) _ (x : 'patt) + (_loc : Gram.Loc.t) -> + (let i = + match x with + | Ast.PaAnt (loc, s) -> + Ast.IdAnt (loc, s) + | p -> Ast.ident_of_patt p + in Ast.PaEq (_loc, i, y) : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sem_patt : 'sem_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'sem_patt) _ (x : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, x, y) : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_patt : 'comma_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'comma_patt) _ (x : 'patt) + (_loc : Gram.Loc.t) -> + (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) + ()); + Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.TyNil _loc : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (x : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "and"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'constructor_arg_list) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "*"; + Gram.Snterm + (Gram.Entry.obj + (star_ctyp : 'star_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'star_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (z : 'label_declaration_list) _ + (y : 'more_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)), + z) : + 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'more_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)); + Gram.Skeyword "|"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)) ], + (Gram.Action.mk + (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyOr (_loc, + (Ast.TyOfAmp (_loc, x, y)), z) : + 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)); + Gram.Skeyword "|"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declarations : + 'constructor_declarations Gram.Entry.t)) ], + (Gram.Action.mk + (fun (z : 'constructor_declarations) _ + (y : 'constructor_arg_list) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), + z) : + 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'constructor_arg_list) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "|"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declarations : + 'constructor_declarations Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'constructor_declarations) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'label_declaration_list) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> + (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) + ()); + Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'type_parameter) (_loc : Gram.Loc.t) + -> (x : 'more_ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> + (x : 'more_ctyp)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.TyVrn (_loc, x) : 'more_ctyp)))); + ([ Gram.Skeyword "mutable"; Gram.Sself ], + (Gram.Action.mk + (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) -> + (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) + ()); + Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.StNil _loc : 'str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (st : 'str_item) (_loc : Gram.Loc.t) -> + (st : 'str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (st2 : 'str_item_quot) _ + (st1 : 'str_item) (_loc : Gram.Loc.t) -> + (match st2 with + | Ast.StNil _ -> st1 + | _ -> Ast.StSem (_loc, st1, st2) : + 'str_item_quot)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) + ()); + Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.SgNil _loc : 'sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sg : 'sig_item) (_loc : Gram.Loc.t) -> + (sg : 'sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (sg2 : 'sig_item_quot) _ + (sg1 : 'sig_item) (_loc : Gram.Loc.t) -> + (match sg2 with + | Ast.SgNil _ -> sg1 + | _ -> Ast.SgSem (_loc, sg1, sg2) : + 'sig_item_quot)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Gram.Loc.t) -> + (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) + ()); + Gram.extend + (module_type_quot : 'module_type_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.MtNil _loc : 'module_type_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'module_type) (_loc : Gram.Loc.t) -> + (x : 'module_type_quot)))) ]) ])) + ()); + Gram.extend + (module_expr_quot : 'module_expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.MeNil _loc : 'module_expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'module_expr) (_loc : Gram.Loc.t) -> + (x : 'module_expr_quot)))) ]) ])) + ()); + Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.McNil _loc : 'match_case_quot)))); + ([ Gram.Slist0sep + ((Gram.Snterm + (Gram.Entry.obj + (match_case0 : + 'match_case0 Gram.Entry.t))), + (Gram.Skeyword "|")) ], + (Gram.Action.mk + (fun (x : 'match_case0 list) + (_loc : Gram.Loc.t) -> + (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ])) + ()); + Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.BiNil _loc : 'binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'binding) (_loc : Gram.Loc.t) -> + (x : 'binding_quot)))) ]) ])) + ()); + Gram.extend + (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.RbNil _loc : 'rec_binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr_list : + 'label_expr_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'label_expr_list) + (_loc : Gram.Loc.t) -> + (x : 'rec_binding_quot)))) ]) ])) + ()); + Gram.extend + (module_binding_quot : 'module_binding_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.MbNil _loc : 'module_binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) + _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.MbColEq (_loc, m, mt, me) : + 'module_binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (m : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (Ast.MbCol (_loc, m, mt) : + 'module_binding_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) + _ (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbColEq (_loc, (mk_anti n m), mt, + me) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbCol (_loc, (mk_anti n m), mt) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (Ast.MbAnt (_loc, + (mk_anti ~c: "module_binding" n s)) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("module_binding" | "anti"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("module_binding" | "anti" as n)), s) + -> + (Ast.MbAnt (_loc, + (mk_anti ~c: "module_binding" n s)) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'module_binding_quot) _ + (b1 : 'module_binding_quot) + (_loc : Gram.Loc.t) -> + (Ast.MbAnd (_loc, b1, b2) : + 'module_binding_quot)))) ]) ])) + ()); + Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "apply"), None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident_quot) (i : 'ident_quot) + (_loc : Gram.Loc.t) -> + (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); + ((Some "."), None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident_quot) _ (i : 'ident_quot) + (_loc : Gram.Loc.t) -> + (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t) + -> (i : 'ident_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (i : 'ident_quot) _ + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAcc (_loc, + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s))), + i) : + 'ident_quot) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdLid (_loc, i) : 'ident_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> + (Ast.IdUid (_loc, i) : 'ident_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), + s) -> + (Ast.IdAnt (_loc, + (mk_anti ~c: "ident" n s)) : + 'ident_quot) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.CeNil _loc : 'class_expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_expr) (_loc : Gram.Loc.t) -> + (x : 'class_expr_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("virtual", _) -> true + | _ -> false), + "ANTIQUOT (\"virtual\", _)")); + Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_comma_ctyp : + 'opt_comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ot : 'opt_comma_ctyp) (i : 'ident) + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" as n)), s) -> + (let anti = + Ast.ViAnt + (mk_anti ~c: "class_expr" n s) + in Ast.CeCon (_loc, anti, i, ot) : + 'class_expr_quot) + | _ -> assert false))); + ([ Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) _ + (_loc : Gram.Loc.t) -> + (Ast.CeCon (_loc, Ast.ViVirtual, + (Ast.IdLid (_loc, i)), ot) : + 'class_expr_quot)))); + ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], + (Gram.Action.mk + (fun (ce2 : 'class_expr_quot) _ + (ce1 : 'class_expr_quot) + (_loc : Gram.Loc.t) -> + (Ast.CeEq (_loc, ce1, ce2) : + 'class_expr_quot)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (ce2 : 'class_expr_quot) _ + (ce1 : 'class_expr_quot) + (_loc : Gram.Loc.t) -> + (Ast.CeAnd (_loc, ce1, ce2) : + 'class_expr_quot)))) ]) ])) + ()); + Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.CtNil _loc : 'class_type_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_type_plus) + (_loc : Gram.Loc.t) -> + (x : 'class_type_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("virtual", _) -> true + | _ -> false), + "ANTIQUOT (\"virtual\", _)")); + Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_comma_ctyp : + 'opt_comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ot : 'opt_comma_ctyp) (i : 'ident) + (__camlp4_0 : Gram.Token.t) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" as n)), s) -> + (let anti = + Ast.ViAnt + (mk_anti ~c: "class_type" n s) + in Ast.CtCon (_loc, anti, i, ot) : + 'class_type_quot) + | _ -> assert false))); + ([ Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) _ + (_loc : Gram.Loc.t) -> + (Ast.CtCon (_loc, Ast.ViVirtual, + (Ast.IdLid (_loc, i)), ot) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) + (_loc : Gram.Loc.t) -> + (Ast.CtCol (_loc, ct1, ct2) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) + (_loc : Gram.Loc.t) -> + (Ast.CtEq (_loc, ct1, ct2) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) + (_loc : Gram.Loc.t) -> + (Ast.CtAnd (_loc, ct1, ct2) : + 'class_type_quot)))) ]) ])) + ()); + Gram.extend + (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.CrNil _loc : 'class_str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_str_item) (_loc : Gram.Loc.t) + -> (x : 'class_str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (x2 : 'class_str_item_quot) _ + (x1 : 'class_str_item) (_loc : Gram.Loc.t) + -> + (match x2 with + | Ast.CrNil _ -> x1 + | _ -> Ast.CrSem (_loc, x1, x2) : + 'class_str_item_quot)))) ]) ])) + ()); + Gram.extend + (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.CgNil _loc : 'class_sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_sig_item) (_loc : Gram.Loc.t) + -> (x : 'class_sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (x2 : 'class_sig_item_quot) _ + (x1 : 'class_sig_item) (_loc : Gram.Loc.t) + -> + (match x2 with + | Ast.CgNil _ -> x1 + | _ -> Ast.CgSem (_loc, x1, x2) : + 'class_sig_item_quot)))) ]) ])) + ()); + Gram.extend + (with_constr_quot : 'with_constr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Gram.Loc.t) -> + (Ast.WcNil _loc : 'with_constr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (with_constr : 'with_constr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'with_constr) (_loc : Gram.Loc.t) -> + (x : 'with_constr_quot)))) ]) ])) + ()); + Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_rec) (_loc : Gram.Loc.t) -> + (x : 'rec_flag_quot)))) ]) ])) + ()); + Gram.extend + (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (direction_flag : + 'direction_flag Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'direction_flag) (_loc : Gram.Loc.t) + -> (x : 'direction_flag_quot)))) ]) ])) + ()); + Gram.extend + (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) -> + (x : 'mutable_flag_quot)))) ]) ])) + ()); + Gram.extend + (private_flag_quot : 'private_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_private) (_loc : Gram.Loc.t) -> + (x : 'private_flag_quot)))) ]) ])) + ()); + Gram.extend + (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) -> + (x : 'virtual_flag_quot)))) ]) ])) + ()); + Gram.extend + (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) -> + (x : 'row_var_flag_quot)))) ]) ])) + ()); + Gram.extend + (override_flag_quot : 'override_flag_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_override : + 'opt_override Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'opt_override) (_loc : Gram.Loc.t) + -> (x : 'override_flag_quot)))) ]) ])) + ()); + Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'patt_eoi) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) + (_loc : Gram.Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'expr_eoi) + | _ -> assert false))) ]) ])) + ())) + in apply () end @@ -15201,7 +15450,7 @@ module L = Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword "]" ]; true) - with | Not_found -> false + with | Struct.Grammar.Delete.Rule_not_found _ -> false let comprehension_or_sem_expr_for_list = Gram.Entry.mk "comprehension_or_sem_expr_for_list" diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl index 45f15b99..2a764345 100644 --- a/camlp4/man/camlp4.1.tpl +++ b/camlp4/man/camlp4.1.tpl @@ -11,8 +11,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: camlp4.1.tpl 12800 2012-07-30 18:59:07Z doligez $ -.\" .TH CAMLP4 1 "" "INRIA" .SH NAME camlp4 - Pre-Precessor-Pretty-Printer for OCaml diff --git a/config/Makefile-templ b/config/Makefile-templ index c82137a9..409cd01f 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile-templ 12027 2012-01-16 09:05:37Z frisch $ - ### Compile-time configuration ########## General configuration diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 2b92475b..30b30b5a 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.mingw 12461 2012-05-15 14:18:16Z frisch $ - # Configuration for Windows, Mingw compiler ######### General configuration @@ -60,8 +58,6 @@ SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= -DBM_INCLUDES= -DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= @@ -69,7 +65,7 @@ MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=$(TOOLPREF)as -ASPP=gcc +ASPP=$(TOOLPREF)gcc -c ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= @@ -147,7 +143,7 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' +PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o' ############# Configuration for the contributed libraries @@ -168,3 +164,12 @@ TK_LINK=$(TK_ROOT)/bin/tk85.dll $(TK_ROOT)/bin/tcl85.dll -lws2_32 MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) + +############# for the testsuite makefiles +#ml let topdir = "" and wintopdir = "";; +OTOPDIR=$(WINTOPDIR) +CTOPDIR=$(TOPDIR) +CYGPATH=cygpath -m +DIFF=diff -q --strip-trailing-cr +CANKILL=false +SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 0823be5f..956ff32a 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.mingw 11319 2011-12-16 17:02:48Z xleroy $ - # Configuration for Windows, Mingw compiler ######### General configuration @@ -60,8 +58,6 @@ SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= -DBM_INCLUDES= -DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= @@ -69,7 +65,7 @@ MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=$(TOOLPREF)as -ASPP=gcc +ASPP=$(TOOLPREF)gcc -c ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= @@ -147,7 +143,7 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' +PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o' ############# Configuration for the contributed libraries @@ -165,3 +161,12 @@ TK_LINK= MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) + +############# for the testsuite makefiles +#ml let topdir = "" and wintopdir = "";; +OTOPDIR=$(WINTOPDIR) +CTOPDIR=$(TOPDIR) +CYGPATH=cygpath -m +DIFF=diff -q --strip-trailing-cr +CANKILL=false +SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" diff --git a/config/Makefile.msvc b/config/Makefile.msvc index db3da6d1..80e8f2d1 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.msvc 12461 2012-05-15 14:18:16Z frisch $ - # Configuration for Windows, Visual C++ compiler ######### General configuration @@ -53,8 +51,6 @@ SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= -DBM_INCLUDES= -DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= @@ -174,3 +170,14 @@ TK_LINK=tk85.lib tcl85.lib ws2_32.lib MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) + +############# for the testsuite makefiles +#ml let topdir = "" and wintopdir = "";; +OTOPDIR=$(WINTOPDIR) +CTOPDIR=$(WINTOPDIR) +CYGPATH=cygpath -m +DIFF=diff -q --strip-trailing-cr +CANKILL=false +FIND=/usr/bin/find +SORT=/usr/bin/sort +SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index c832f301..b85d9fed 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -11,8 +11,6 @@ # # ######################################################################### -# $Id: Makefile.msvc64 12461 2012-05-15 14:18:16Z frisch $ - # Configuration for Windows, Visual C++ compiler ######### General configuration @@ -54,8 +52,6 @@ SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= -DBM_INCLUDES= -DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= @@ -145,7 +141,7 @@ NATIVECCCOMPOPTS=/Ox /MD NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:' +PACKLD=link /lib /nologo /machine:AMD64 /out:# must have no space after '/out:' ############# Configuration for camlp4 @@ -170,3 +166,14 @@ TK_LINK= MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) + +############# for the testsuite makefiles +#ml let topdir = "" and wintopdir = "";; +OTOPDIR=$(WINTOPDIR) +CTOPDIR=$(WINTOPDIR) +CYGPATH=cygpath -m +DIFF=diff -q --strip-trailing-cr +CANKILL=false +FIND=/usr/bin/find +SORT=/usr/bin/sort +SET_LD_PATH=PATH="$(PATH):$(LD_PATH)" diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c index 0fd7631f..579db9c6 100644 --- a/config/auto-aux/align.c +++ b/config/auto-aux/align.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: align.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c index fb1188a0..3e2bb983 100644 --- a/config/auto-aux/async_io.c +++ b/config/auto-aux/async_io.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: async_io.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/bytecopy.c b/config/auto-aux/bytecopy.c index bdac9e94..34f29c48 100644 --- a/config/auto-aux/bytecopy.c +++ b/config/auto-aux/bytecopy.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: bytecopy.c 11156 2011-07-27 14:17:02Z doligez $ */ - char buffer[27]; #ifdef reverse diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c index 3eb09397..e86fb198 100644 --- a/config/auto-aux/dblalign.c +++ b/config/auto-aux/dblalign.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: dblalign.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c index fe6d672d..e85e4b3f 100644 --- a/config/auto-aux/divmod.c +++ b/config/auto-aux/divmod.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: divmod.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Test semantics of division and modulus for negative arguments */ long div4[] = diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c index dec1bd58..c7548ae4 100644 --- a/config/auto-aux/elf.c +++ b/config/auto-aux/elf.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: elf.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include int main(int argc, char ** argv) diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c index 7276cf87..91312f71 100644 --- a/config/auto-aux/endian.c +++ b/config/auto-aux/endian.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: endian.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include "m.h" #ifndef ARCH_SIXTYFOUR diff --git a/config/auto-aux/expm1.c b/config/auto-aux/expm1.c index db4413b9..2cfbe737 100644 --- a/config/auto-aux/expm1.c +++ b/config/auto-aux/expm1.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id$ */ - #include volatile double x; diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c index 24cfd395..e3f73f52 100644 --- a/config/auto-aux/getgroups.c +++ b/config/auto-aux/getgroups.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: getgroups.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c index 67beee9b..f09d65a8 100644 --- a/config/auto-aux/gethostbyaddr.c +++ b/config/auto-aux/gethostbyaddr.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: gethostbyaddr.c 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef _REENTRANT /* This helps detection on Digital Unix... */ #define _REENTRANT diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c index 9db83c11..da52d89b 100644 --- a/config/auto-aux/gethostbyname.c +++ b/config/auto-aux/gethostbyname.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: gethostbyname.c 11156 2011-07-27 14:17:02Z doligez $ */ - #ifndef _REENTRANT /* This helps detection on Digital Unix... */ #define _REENTRANT diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c index 28960e74..47bafb60 100644 --- a/config/auto-aux/ia32sse2.c +++ b/config/auto-aux/ia32sse2.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: ia32sse2.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* Test whether IA32 assembler supports SSE2 instructions */ int main() diff --git a/config/auto-aux/initgroups.c b/config/auto-aux/initgroups.c index 2634aaf7..0086e92a 100644 --- a/config/auto-aux/initgroups.c +++ b/config/auto-aux/initgroups.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: initgroups.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c index 0d281f76..9ae8a5bc 100644 --- a/config/auto-aux/int64align.c +++ b/config/auto-aux/int64align.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64align.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/longlong.c b/config/auto-aux/longlong.c index fe5ad7fd..e18f9e28 100644 --- a/config/auto-aux/longlong.c +++ b/config/auto-aux/longlong.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: longlong.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include diff --git a/config/auto-aux/schar.c b/config/auto-aux/schar.c index fc2199c2..a9c355e5 100644 --- a/config/auto-aux/schar.c +++ b/config/auto-aux/schar.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: schar.c 11156 2011-07-27 14:17:02Z doligez $ */ - char foo[]="\377"; int main(int argc, char ** argv) diff --git a/config/auto-aux/schar2.c b/config/auto-aux/schar2.c index 7295d608..9d18d2ac 100644 --- a/config/auto-aux/schar2.c +++ b/config/auto-aux/schar2.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: schar2.c 11156 2011-07-27 14:17:02Z doligez $ */ - signed char foo[]="\377"; int main(int argc, char ** argv) diff --git a/config/auto-aux/setgroups.c b/config/auto-aux/setgroups.c index 0d5cc7f6..4be3c1d7 100644 --- a/config/auto-aux/setgroups.c +++ b/config/auto-aux/setgroups.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: setgroups.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c index bbd34b9a..3c341fea 100644 --- a/config/auto-aux/sighandler.c +++ b/config/auto-aux/sighandler.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: sighandler.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include int main(void) diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c index f102208e..ed84e980 100644 --- a/config/auto-aux/signals.c +++ b/config/auto-aux/signals.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */ - /* To determine the semantics of signal handlers (System V: signal is reset to default behavior on entrance to the handler BSD: signal handler remains active). */ diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c index df8fe638..2700729d 100644 --- a/config/auto-aux/sizes.c +++ b/config/auto-aux/sizes.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: sizes.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include int main(int argc, char **argv) diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index 69e0e9ae..3e3181bd 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: stackov.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c index 335a4b6e..4608ee9f 100644 --- a/config/auto-aux/tclversion.c +++ b/config/auto-aux/tclversion.c @@ -14,8 +14,6 @@ /* */ /***********************************************************************/ -/* $Id: tclversion.c 11156 2011-07-27 14:17:02Z doligez $ */ - #include #include #include diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble index 7cd5582c..06b9b27c 100644 --- a/config/auto-aux/tryassemble +++ b/config/auto-aux/tryassemble @@ -1,4 +1,18 @@ #!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 2012 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../../LICENSE. # +# # +######################################################################### + if test "$verbose" = yes; then echo "tryassemble: $aspp -o tst $*" >&2 $aspp -o tst $* || exit 100 diff --git a/config/m-nt.h b/config/m-nt.h index 3ed75721..a80b0ac5 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: m-nt.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Machine configuration, Intel x86 processors, Win32, Visual C++ or Mingw compiler */ diff --git a/config/m-templ.h b/config/m-templ.h index 3101163d..a5497b56 100644 --- a/config/m-templ.h +++ b/config/m-templ.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: m-templ.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Processor dependencies */ #define ARCH_SIXTYFOUR diff --git a/config/s-nt.h b/config/s-nt.h index 020d6c94..6df440b8 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: s-nt.h 12030 2012-01-16 10:23:51Z frisch $ */ - /* Operating system dependencies, Intel x86 processors, Windows NT */ #define OCAML_OS_TYPE "Win32" @@ -28,3 +26,4 @@ #define HAS_PUTENV #define HAS_LOCALE #define HAS_BROKEN_PRINTF +#define HAS_IPV6 diff --git a/config/s-templ.h b/config/s-templ.h index 057e40e0..d0748ae2 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: s-templ.h 11156 2011-07-27 14:17:02Z doligez $ */ - /* Operating system and standard library dependencies. */ /* 0. Operating system type string. */ diff --git a/configure b/configure index e08bbce3..07b1c350 100755 --- a/configure +++ b/configure @@ -13,8 +13,6 @@ # # ######################################################################### -# $Id: configure 12645 2012-06-26 15:33:50Z doligez $ - configure_options="$*" prefix=/usr/local bindir='' @@ -45,6 +43,8 @@ withsharedlibs=yes gcc_warnings="-Wall" partialld="ld -r" withcamlp4=camlp4 +with_frame_pointers=false +with_cfi=true # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -117,6 +117,10 @@ while : ; do debugruntime=runtimed;; -no-camlp4|--no-camlp4) withcamlp4="";; + -with-frame-pointers|--with-frame-pointers) + with_frame_pointers=true;; + -no-cfi|--no-cfi) + with_cfi=false;; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift @@ -276,6 +280,7 @@ case "$bytecc,$host" in *,*-*-darwin*) bytecccompopts="-fno-defer-pop $gcc_warnings" mathlib="" + mkexe="$mkexe -Wl,-no_compact_unwind" # Tell gcc that we can use 32-bit code addresses for threaded code # unless we are compiled for a shared library (-fPIC option) echo "#ifndef __PIC__" >> m.h @@ -473,9 +478,9 @@ case "$host" in 1) echo "Doubles must be doubleword-aligned." echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; *) echo "Something went wrong during alignment determination for doubles." - echo "I'm going to assume this architecture has alignment constraints over doubles." + echo "We will assume alignment constraints over doubles." echo "That's a safe bet: OCaml will work even if" - echo "this architecture has actually no alignment constraints." + echo "this architecture actually has no alignment constraints." echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; esac;; esac @@ -498,9 +503,9 @@ if $int64_native; then echo "#undef ARCH_ALIGN_INT64" >> m.h;; 1) echo "64-bit integers must be doubleword-aligned." echo "#define ARCH_ALIGN_INT64" >> m.h;; - *) echo "Something went wrong during alignment determination for 64-bit integers." - echo "I'm going to assume this architecture has alignment constraints." - echo "That's a safe bet: OCaml will work even if" + *) echo "Something went wrong during alignment determination for 64-bit" + echo "integers. I'm going to assume this architecture has alignment" + echo "constraints. That's a safe bet: OCaml will work even if" echo "this architecture has actually no alignment constraints." echo "#define ARCH_ALIGN_INT64" >> m.h;; esac @@ -513,11 +518,14 @@ fi sh ./runtest divmod.c case $? in - 0) echo "Native division and modulus have round-towards-zero semantics, will use them." + 0) echo "Native division and modulus have round-towards-zero semantics," + echo "will use them." echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation." + 1) echo "Native division and modulus do not have round-towards-zero" + echo "semantics, will use software emulation." echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - *) echo "Something went wrong while checking native division and modulus, please report it." + *) echo "Something went wrong while checking native division and modulus," + echo "please report it at http://http://caml.inria.fr/mantis/" echo "#define NONSTANDARD_DIV_MOD" >> m.h;; esac @@ -537,7 +545,7 @@ if test $withsharedlibs = "yes"; then mksharedlib="$flexlink" mkmaindll="$flexlink -maindll" shared_libraries_supported=true;; - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" @@ -598,7 +606,7 @@ if test $withsharedlibs = "yes"; then dl_needs_underscore=false shared_libraries_supported=true;; *-apple-darwin*) - mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" + mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -Wl,-no_compact_unwind" bytecccompopts="$dl_defs $bytecccompopts" dl_needs_underscore=false shared_libraries_supported=true;; @@ -688,9 +696,11 @@ case "$host" in i[3456]86-*-gnu*) arch=i386; system=gnu;; powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; + powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody - if $arch64; then model=ppc64; else model=ppc; fi;; + if $arch64;then model=ppc64;else model=ppc;fi;; + armv6*-*-linux-gnueabihf) arch=arm; model=armv6; system=linux_eabihf;; arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;; armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;; @@ -725,6 +735,8 @@ fi nativecccompopts='' 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,$host_type" in @@ -743,8 +755,13 @@ esac asppprofflags='-DPROFILING' case "$arch,$model,$system" in - amd64,*,macosx) as='as -arch x86_64' - aspp='gcc -arch x86_64 -c';; + amd64,*,macosx) if ./searchpath clang; then + as='clang -arch x86_64 -c' + aspp='clang -arch x86_64 -c' + else + as='as -arch x86_64' + aspp='gcc -arch x86_64 -c' + fi;; amd64,*,solaris) as='as --64' aspp='gcc -m64 -c';; amd64,*,*) as='as' @@ -757,7 +774,7 @@ case "$arch,$model,$system" in aspp='gcc -c';; power,*,elf) as='as -u -m ppc' aspp='gcc -c';; - power,*,bsd) as='as' + power,*,bsd*) as='as' aspp='gcc -c';; power,*,rhapsody) as="as -arch $model" aspp="$bytecc -c";; @@ -815,7 +832,7 @@ if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then echo "SHARPBANGSCRIPTS=false" >> Makefile;; *-*-cygwin*) echo "We won't use it, though, because of conflicts with .exe extension" - echo "under Cygwin" + echo " under Cygwin" echo "SHARPBANGSCRIPTS=false" >> Makefile;; *) echo "SHARPBANGSCRIPTS=true" >> Makefile;; @@ -1433,6 +1450,8 @@ if test $has_tk = true; then for tk_incs in \ "-I/usr/local/include" \ "-I/usr/include" \ + "-I/usr/local/include/tcl8.6 -I/usr/local/include/tk8.6" \ + "-I/usr/include/tcl8.6 -I/usr/include/tk8.6" \ "-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \ "-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \ "-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \ @@ -1450,6 +1469,7 @@ if test $has_tk = true; then if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then echo "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"." case $tcl_version in + 8.6) tclmaj=8 tclmin=6 tkmaj=8 tkmin=6 ;; 8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;; 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; @@ -1559,7 +1579,9 @@ asm_cfi_supported=false export as aspp -if sh ./tryassemble cfi.S; then +if ! $with_cfi; then + echo "CFI support: disabled by command-line option -no-cfi" +elif sh ./tryassemble cfi.S; then echo "#define ASM_CFI_SUPPORTED" >> m.h asm_cfi_supported=true echo "Assembler supports CFI" @@ -1567,6 +1589,20 @@ else echo "Assembler does not support CFI" fi +if test "$with_frame_pointers" = "true"; then + case "$host,$cc" in + x86_64-*-linux*,gcc*) + nativecccompopts="$nativecccompopts -g -fno-omit-frame-pointer" + bytecccompopts="$bytecccompopts -g -fno-omit-frame-pointer" + nativecclinkopts="$nativecclinkopts -g" + echo "#define WITH_FRAME_POINTERS" >> m.h + ;; + *) echo "Unsupported architecture with frame pointers" 1>&2; exit 2;; + esac + +fi + + # Final twiddling of compiler options to work around known bugs nativeccprofopts="$nativecccompopts" @@ -1640,6 +1676,11 @@ echo "MKMAINDLL=$mkmaindll" >> Makefile echo "RUNTIMED=${debugruntime}" >>Makefile echo "CAMLP4=${withcamlp4}" >>Makefile echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile +echo "WITH_FRAME_POINTERS=$with_frame_pointers" >> Makefile +if [ "$ostype" = Cygwin ]; then + echo "DIFF=diff -q --strip-trailing-cr" >>Makefile +fi + rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile @@ -1689,6 +1730,11 @@ else else echo " assembler supports CFI ... no" fi + if test "$with_frame_pointers" = "true"; then + echo " with frame pointers....... yes" + else + echo " with frame pointers....... no" + fi echo " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" diff --git a/debugger/.depend b/debugger/.depend index ec87403c..60b0baef 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -4,8 +4,6 @@ command_line.cmi : debugcom.cmi : primitives.cmi debugger_config.cmi : dynlink.cmi : -envaux.cmi : ../typing/subst.cmi ../typing/path.cmi ../bytecomp/instruct.cmi \ - ../typing/env.cmi eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ ../typing/env.cmi debugcom.cmi @@ -50,9 +48,9 @@ command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../parsing/location.cmi loadprinter.cmi lexer.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi history.cmi frames.cmi \ - events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \ - ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \ - command_line.cmi + events.cmi eval.cmi ../typing/envaux.cmi ../typing/env.cmi \ + debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../utils/config.cmi \ + checkpoints.cmi breakpoints.cmi command_line.cmi command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \ show_source.cmx show_information.cmx question.cmx program_management.cmx \ @@ -60,9 +58,9 @@ command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/longident.cmx \ ../parsing/location.cmx loadprinter.cmx lexer.cmx int64ops.cmx \ ../bytecomp/instruct.cmx input_handling.cmx history.cmx frames.cmx \ - events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \ - ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \ - command_line.cmi + events.cmx eval.cmx ../typing/envaux.cmx ../typing/env.cmx \ + debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \ + checkpoints.cmx breakpoints.cmx command_line.cmi debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \ input_handling.cmi debugcom.cmi debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \ @@ -77,12 +75,6 @@ dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ ../typing/cmi_format.cmx dynlink.cmi -envaux.cmo : ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \ - ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \ - ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi -envaux.cmx : ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \ - ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \ - ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \ @@ -135,9 +127,9 @@ main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ command_line.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ checkpoints.cmx -parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \ +parameters.cmo : primitives.cmi ../typing/envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi -parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \ +parameters.cmx : primitives.cmx ../typing/envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ input_handling.cmi parser.cmi diff --git a/debugger/Makefile b/debugger/Makefile index a2eb4116..cf0fffb9 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -10,7 +10,5 @@ # # ######################################################################### -# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $ - UNIXDIR=../otherlibs/unix include Makefile.shared diff --git a/debugger/Makefile.nt b/debugger/Makefile.nt index 84619bac..4182c7c7 100644 --- a/debugger/Makefile.nt +++ b/debugger/Makefile.nt @@ -10,7 +10,5 @@ # # ######################################################################### -# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $ - UNIXDIR=../otherlibs/win32unix include Makefile.shared diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index f27c776e..528bbfee 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile.shared 12526 2012-05-31 12:41:49Z lefessan $ - include ../config/Makefile CAMLC=../ocamlcomp.sh @@ -35,8 +33,10 @@ OTHEROBJS=\ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ ../typing/subst.cmo ../typing/predef.cmo \ - ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo ../typing/oprint.cmo \ + ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo \ + ../typing/oprint.cmo \ ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ + ../typing/envaux.cmo \ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ ../bytecomp/opcodes.cmo \ @@ -49,7 +49,6 @@ OBJS=\ primitives.cmo \ unix_tools.cmo \ debugger_config.cmo \ - envaux.cmo \ parameters.cmo \ lexer.cmo \ input_handling.cmo \ diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml index bfab44d4..de4c95bd 100644 --- a/debugger/breakpoints.ml +++ b/debugger/breakpoints.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: breakpoints.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (******************************* Breakpoints ***************************) open Checkpoints @@ -67,7 +65,8 @@ let rec breakpoints_at_pc pc = [] end @ - List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) + List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) + !breakpoints) (* Is there a breakpoint at `pc' ? *) let breakpoint_at_pc pc = @@ -169,7 +168,7 @@ let rec new_breakpoint = incr breakpoint_number; insert_position event.ev_pos; breakpoints := (!breakpoint_number, event) :: !breakpoints); - printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos + printf "Breakpoint %d at %d: %s" !breakpoint_number event.ev_pos (Pos.get_desc event); print_newline () @@ -182,7 +181,7 @@ let remove_breakpoint number = (function () -> breakpoints := List.remove_assoc number !breakpoints; remove_position pos; - printf "Removed breakpoint %d at %d : %s" number ev.ev_pos + printf "Removed breakpoint %d at %d: %s" number ev.ev_pos (Pos.get_desc ev); print_newline () ) diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli index 075608eb..ef518852 100644 --- a/debugger/breakpoints.mli +++ b/debugger/breakpoints.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: breakpoints.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (******************************* Breakpoints ***************************) open Primitives diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml index 9ca303ad..f0df2389 100644 --- a/debugger/checkpoints.ml +++ b/debugger/checkpoints.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: checkpoints.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (*************************** Checkpoints *******************************) open Int64ops diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli index 269aaf26..95eaf1b0 100644 --- a/debugger/checkpoints.mli +++ b/debugger/checkpoints.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: checkpoints.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (***************************** Checkpoints *****************************) open Primitives diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 19fab689..d1086215 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: command_line.ml 12800 2012-07-30 18:59:07Z doligez $ *) - (************************ Reading and executing commands ***************) open Int64ops @@ -126,7 +124,7 @@ let add_breakpoint_at_pc pc = new_breakpoint (any_event_at_pc pc) with | Not_found -> - eprintf "Can't add breakpoint at pc %i : no event there.@." pc; + eprintf "Can't add breakpoint at pc %i: no event there.@." pc; raise Toplevel let add_breakpoint_after_pc pc = @@ -187,6 +185,8 @@ let interprete_line ppf line = with | Parsing.Parse_error -> error "Syntax error." + | Failure "int_of_string" -> + error "Integer overflow" let line_loop ppf line_buffer = resume_user_input (); @@ -210,7 +210,7 @@ let line_loop ppf line_buffer = | Exit -> stop_user_input () (* | Sys_error s -> - error ("System error : " ^ s) *) + error ("System error: " ^ s) *) (** Instructions. **) let instr_cd ppf lexbuf = @@ -263,16 +263,18 @@ let instr_dir ppf lexbuf = else begin let new_directory' = List.rev new_directory in match new_directory' with - | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 -> + | mdl :: for_keyw :: tl + when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 -> List.iter (function x -> add_path_for mdl (expand_path x)) tl | _ -> List.iter (function x -> add_path (expand_path x)) new_directory' end; let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in - fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path; + fprintf ppf "@[<2>Directories: %a@]@." print_dirs !Config.load_path; Hashtbl.iter (fun mdl dirs -> - fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs) + fprintf ppf "@[<2>Source directories for %s: %a@]@." mdl print_dirs + dirs) Debugger_config.load_path_for let instr_kill ppf lexbuf = @@ -371,11 +373,11 @@ let instr_quit _ = let print_variable_list ppf = let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in - fprintf ppf "List of variables :%a@." pr_vars !variable_list + fprintf ppf "List of variables: %a@." pr_vars !variable_list let print_info_list ppf = let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in - fprintf ppf "List of info commands :%a@." pr_infos !info_list + fprintf ppf "List of info commands: %a@." pr_infos !info_list let instr_complete ppf lexbuf = let ppf = Format.err_formatter in @@ -431,7 +433,7 @@ let instr_help ppf lexbuf = | Some x -> let print_help nm hlp = eol lexbuf; - fprintf ppf "%s : %s@." nm hlp in + fprintf ppf "%s: %s@." nm hlp in begin match matching_instructions x with | [] -> eol lexbuf; @@ -467,10 +469,10 @@ let instr_help ppf lexbuf = print_help i.instr_name i.instr_help | l -> eol lexbuf; - fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l + fprintf ppf "Ambiguous command \"%s\": %a@." x pr_instrs l end | None -> - fprintf ppf "List of commands : %a@." pr_instrs !instruction_list + fprintf ppf "List of commands: %a@." pr_instrs !instruction_list (* Printing values *) @@ -483,12 +485,18 @@ let print_expr depth ev env ppf expr = Eval.report_error ppf msg; raise Toplevel +let env_of_event = + function + None -> Env.empty + | Some ev -> + Envaux.env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst + let print_command depth ppf lexbuf = let exprs = expression_list_eol Lexer.lexeme lexbuf in ensure_loaded (); let env = try - Envaux.env_of_event !selected_event + env_of_event !selected_event with | Envaux.Error msg -> Envaux.report_error ppf msg; @@ -548,7 +556,7 @@ let instr_show = (function ppf -> List.iter (function {var_name = nm; var_action = (_, funct)} -> - fprintf ppf "%s : " nm; + fprintf ppf "%s: " nm; funct ppf) !variable_list) @@ -573,7 +581,7 @@ let instr_break ppf lexbuf = | BA_function expr -> (* break FUNCTION *) let env = try - Envaux.env_of_event !selected_event + env_of_event !selected_event with | Envaux.Error msg -> Envaux.report_error ppf msg; @@ -616,7 +624,9 @@ let instr_break ppf lexbuf = raise Toplevel) | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) try - new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position) + new_breakpoint + (event_near_pos (convert_module (module_of_longident mdle)) + position) with | Not_found -> eprintf "Can't find any event there.@." @@ -843,18 +853,18 @@ let follow_fork_variable = let pr_modules ppf mods = let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in - fprintf ppf "Used modules :@.%a@?" pr_mods mods + fprintf ppf "Used modules: @.%a@?" pr_mods mods let info_modules ppf lexbuf = eol lexbuf; ensure_loaded (); pr_modules ppf !modules (******** - print_endline "Opened modules :"; + print_endline "Opened modules: "; if !opened_modules_names = [] then print_endline "(no module opened)." else - (List.iter (function x -> print_string x; print_space) !opened_modules_names; + (List.iter (function x -> print_string x;print_space) !opened_modules_names; print_newline ()) *********) @@ -892,8 +902,10 @@ let info_breakpoints ppf lexbuf = let info_events ppf lexbuf = ensure_loaded (); - let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in - print_endline ("Module : " ^ mdle); + let mdle = + convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) + in + print_endline ("Module: " ^ mdle); print_endline " Address Characters Kind Repr."; List.iter (function ev -> @@ -1100,10 +1112,10 @@ using \"load_printer\"." }; var_action = loading_mode_variable ppf; var_help = "mode of loading.\n\ -It can be either :\n\ - direct : the program is directly called by the debugger.\n\ - runtime : the debugger execute `ocamlrun programname arguments'.\n\ - manual : the program is not launched by the debugger,\n\ +It can be either:\n\ + direct: the program is directly called by the debugger.\n\ + runtime: the debugger execute `ocamlrun programname arguments'.\n\ + manual: the program is not launched by the debugger,\n\ but manually by the user." }; { var_name = "processcount"; var_action = integer_variable false 1 "Must be >= 1." @@ -1147,8 +1159,8 @@ It can be either :\n\ var_help = "process to follow after forking.\n\ It can be either : - child : the newly created process.\n\ - parent : the process that called fork.\n" }]; + child: the newly created process.\n\ + parent: the process that called fork.\n" }]; info_list := (* info name, function, help *) diff --git a/debugger/command_line.mli b/debugger/command_line.mli index aea8bfbb..f7fb1605 100644 --- a/debugger/command_line.mli +++ b/debugger/command_line.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: command_line.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (************************ Reading and executing commands ***************) open Lexing;; diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index 1e95e429..72702da1 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: debugcom.ml 12184 2012-02-23 19:54:44Z doligez $ *) - (* Low-level communication with the debuggee *) open Int64ops diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli index 847e9d35..3dce2abb 100644 --- a/debugger/debugcom.mli +++ b/debugger/debugcom.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: debugcom.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Low-level communication with the debuggee *) type execution_summary = diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 46e0932c..a16fdca2 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: debugger_config.ml 12210 2012-03-08 19:52:03Z doligez $ *) - (**************************** Configuration file ***********************) open Int64ops diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 25922ac4..f725acec 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: debugger_config.mli 12210 2012-03-08 19:52:03Z doligez $ *) - (********************** Configuration file *****************************) exception Toplevel diff --git a/debugger/envaux.ml b/debugger/envaux.ml deleted file mode 100644 index 9a58fb69..00000000 --- a/debugger/envaux.ml +++ /dev/null @@ -1,84 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* OCaml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id: envaux.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - -open Misc -open Types -open Env - -type error = - Module_not_found of Path.t - -exception Error of error - -let env_cache = - (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) - -let reset_cache () = - Hashtbl.clear env_cache; - Env.reset_cache() - -let extract_sig env mty = - match Mtype.scrape 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) - with Not_found -> - let env = - match sum with - Env_empty -> - Env.empty - | Env_value(s, id, desc) -> - Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst) - | Env_type(s, id, desc) -> - Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst) - | Env_exception(s, id, desc) -> - Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst) - | Env_module(s, id, desc) -> - Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst) - | Env_modtype(s, id, desc) -> - Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) - | Env_class(s, id, desc) -> - Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst) - | Env_cltype (s, id, desc) -> - Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) - | Env_open(s, path) -> - let env = env_from_summary s subst in - let path' = Subst.module_path subst path in - let mty = - try - Env.find_module path' env - with Not_found -> - raise (Error (Module_not_found path')) - in - Env.open_signature path' (extract_sig env mty) env - in - Hashtbl.add env_cache (sum, subst) env; - env - -let env_of_event = - function - None -> Env.empty - | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst - -(* Error report *) - -open Format - -let report_error ppf = function - | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p diff --git a/debugger/envaux.mli b/debugger/envaux.mli deleted file mode 100644 index 14cbe2db..00000000 --- a/debugger/envaux.mli +++ /dev/null @@ -1,34 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* OCaml port by John Malecki and Xavier Leroy *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* $Id: envaux.mli 12700 2012-07-11 17:23:37Z lefessan $ *) - -open Format - -(* Convert environment summaries to environments *) - -val env_from_summary : Env.summary -> Subst.t -> Env.t -val env_of_event: Instruct.debug_event option -> Env.t - -(* Empty the environment caches. To be called when load_path changes. *) - -val reset_cache: unit -> unit - -(* Error report *) - -type error = - Module_not_found of Path.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/debugger/eval.ml b/debugger/eval.ml index 5917f570..aa006332 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: eval.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - open Misc open Path open Instruct @@ -89,7 +87,8 @@ let rec expression event env = function end | E_result -> begin match event with - Some {ev_kind = Event_after ty; ev_typsubst = subst} when !Frames.current_frame = 0 -> + Some {ev_kind = Event_after ty; ev_typsubst = subst} + when !Frames.current_frame = 0 -> (Debugcom.Remote_value.accu(), Subst.type_expr subst ty) | _ -> raise(Error(No_result)) @@ -183,10 +182,12 @@ let report_error ppf = function pos len Printtyp.type_expr ty | Array_index(len, pos) -> fprintf ppf - "@[Cannot extract element number %i from an array of length %i@]@." pos len + "@[Cannot extract element number %i from an array of length %i@]@." + pos len | List_index(len, pos) -> fprintf ppf - "@[Cannot extract element number %i from a list of length %i@]@." pos len + "@[Cannot extract element number %i from a list of length %i@]@." + pos len | String_index(s, len, pos) -> fprintf ppf "@[Cannot extract character number %i@ \ diff --git a/debugger/eval.mli b/debugger/eval.mli index 71ca75a1..c5e04f33 100644 --- a/debugger/eval.mli +++ b/debugger/eval.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: eval.mli 11156 2011-07-27 14:17:02Z doligez $ *) - open Types open Parser_aux open Format diff --git a/debugger/events.ml b/debugger/events.ml index ed59938d..c622f672 100644 --- a/debugger/events.ml +++ b/debugger/events.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: events.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (********************************* Events ******************************) open Instruct diff --git a/debugger/events.mli b/debugger/events.mli index 4857aa5b..e593be03 100644 --- a/debugger/events.mli +++ b/debugger/events.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: events.mli 11156 2011-07-27 14:17:02Z doligez $ *) - open Instruct val get_pos : debug_event -> Lexing.position;; diff --git a/debugger/exec.ml b/debugger/exec.ml index db2d3662..931c0a91 100644 --- a/debugger/exec.ml +++ b/debugger/exec.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: exec.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Handling of keyboard interrupts *) let interrupted = ref false @@ -29,7 +27,7 @@ let _ = "Win32" -> () | _ -> Sys.set_signal Sys.sigint (Sys.Signal_handle break); - Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) + Sys.set_signal Sys.sigpipe (Sys.Signal_handle(fun _ -> raise End_of_file)) let protect f = if !is_protected then diff --git a/debugger/exec.mli b/debugger/exec.mli index 71b855df..a820589b 100644 --- a/debugger/exec.mli +++ b/debugger/exec.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: exec.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Handling of keyboard interrupts *) val protect : (unit -> unit) -> unit diff --git a/debugger/frames.ml b/debugger/frames.ml index 9ec6e8cc..d3456284 100644 --- a/debugger/frames.ml +++ b/debugger/frames.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: frames.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (***************************** Frames **********************************) open Instruct diff --git a/debugger/frames.mli b/debugger/frames.mli index 70dbf3dd..fa652b0c 100644 --- a/debugger/frames.mli +++ b/debugger/frames.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: frames.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (****************************** Frames *********************************) open Instruct diff --git a/debugger/history.ml b/debugger/history.ml index e84bfc80..4d08f587 100644 --- a/debugger/history.ml +++ b/debugger/history.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: history.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Int64ops open Checkpoints open Primitives diff --git a/debugger/history.mli b/debugger/history.mli index 88b051dc..121c732f 100644 --- a/debugger/history.mli +++ b/debugger/history.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: history.mli 11156 2011-07-27 14:17:02Z doligez $ *) - val empty_history : unit -> unit val add_current_time : unit -> unit diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml index a28b6af1..f3bd57b6 100644 --- a/debugger/input_handling.ml +++ b/debugger/input_handling.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: input_handling.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (**************************** Input control ****************************) open Unix diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli index 0b1c2ea7..749687ce 100644 --- a/debugger/input_handling.mli +++ b/debugger/input_handling.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: input_handling.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (***************************** Input control ***************************) open Primitives diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml index 9a475240..527bdcef 100644 --- a/debugger/int64ops.ml +++ b/debugger/int64ops.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: int64ops.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (****************** arithmetic operators for Int64 *********************) let ( ++ ) = Int64.add;; diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli index 38174b46..5491c8f7 100644 --- a/debugger/int64ops.mli +++ b/debugger/int64ops.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: int64ops.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (****************** arithmetic operators for Int64 *********************) val ( ++ ) : int64 -> int64 -> int64;; diff --git a/debugger/lexer.mli b/debugger/lexer.mli index eeaf8905..7508bedd 100644 --- a/debugger/lexer.mli +++ b/debugger/lexer.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: lexer.mli 11156 2011-07-27 14:17:02Z doligez $ *) - val line: Lexing.lexbuf -> string val lexeme: Lexing.lexbuf -> Parser.token val argument: Lexing.lexbuf -> Parser.token diff --git a/debugger/lexer.mll b/debugger/lexer.mll index 0cd2d6a4..721645c8 100644 --- a/debugger/lexer.mll +++ b/debugger/lexer.mll @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: lexer.mll 11156 2011-07-27 14:17:02Z doligez $ *) - { open Parser diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 44c0108a..98e79d79 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: loadprinter.ml 12673 2012-07-09 12:40:51Z xclerc $ *) - (* Loading and installation of user-defined printer functions *) open Misc diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli index 147eebf2..4851a4d5 100644 --- a/debugger/loadprinter.mli +++ b/debugger/loadprinter.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: loadprinter.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Loading and installation of user-defined printer functions *) open Format diff --git a/debugger/main.ml b/debugger/main.ml index 8a07620d..85bc9afb 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: main.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - open Input_handling open Question open Command_line @@ -74,7 +72,8 @@ let rec protect ppf restart loop = protect ppf restart (function ppf -> let b = if !current_duration = -1L then begin - let msg = sprintf "Restart from time %Ld and try to get closer of the problem" time in + let msg = sprintf "Restart from time %Ld and try to get \ + closer of the problem" time in stop_user_input (); if yes_or_no msg then (current_duration := init_duration; true) diff --git a/debugger/parameters.ml b/debugger/parameters.ml index e958e93c..2e1d4a75 100644 --- a/debugger/parameters.ml +++ b/debugger/parameters.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: parameters.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Miscellaneous parameters *) open Primitives diff --git a/debugger/parameters.mli b/debugger/parameters.mli index 4eeb1346..244d24b3 100644 --- a/debugger/parameters.mli +++ b/debugger/parameters.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: parameters.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Miscellaneous parameters *) val program_name : string ref diff --git a/debugger/parser.mly b/debugger/parser.mly index a48e2618..1d394e34 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly 12210 2012-03-08 19:52:03Z doligez $ */ - %{ open Int64ops diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli index baa8e152..542affbd 100644 --- a/debugger/parser_aux.mli +++ b/debugger/parser_aux.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: parser_aux.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (*open Globals*) open Primitives diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml index e2a99856..7b297869 100644 --- a/debugger/pattern_matching.ml +++ b/debugger/pattern_matching.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: pattern_matching.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (************************ Simple pattern matching **********************) open Debugger_config @@ -91,7 +89,8 @@ let rec pattern_matching pattern obj ty = | P_nth (n, patt) -> if n >= List.length ty_list then (prerr_endline "Out of range."; raise Toplevel); - pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n) + pattern_matching patt (Debugcom.get_field obj n) + (List.nth ty_list n) | _ -> error_matching ()) | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list -> @@ -223,7 +222,8 @@ and match_concrete_type pattern obj cstr ty ty_list = filter (ty_res, ty) with Unify -> fatal_error "pattern_matching: types should match"); - pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg + pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) + ty_arg in (match pattern with P_record pattern_label_list -> diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli index 8cb532e7..71e88c05 100644 --- a/debugger/pattern_matching.mli +++ b/debugger/pattern_matching.mli @@ -11,11 +11,10 @@ (* *) (***********************************************************************) -(* $Id: pattern_matching.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (************************ Simple pattern matching **********************) open Parser_aux val pattern_matching : - pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;; + pattern -> Debugcom.remote_value -> Typedtree.type_expr -> + (string * Debugcom.remote_value * Typedtree.type_expr) list;; diff --git a/debugger/pos.ml b/debugger/pos.ml index d8fb38fb..c9e93280 100644 --- a/debugger/pos.ml +++ b/debugger/pos.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: pos.ml 11166 2011-08-04 14:59:13Z doligez $ *) - open Instruct;; open Lexing;; open Location;; diff --git a/debugger/pos.mli b/debugger/pos.mli index 76835b66..4eacab78 100644 --- a/debugger/pos.mli +++ b/debugger/pos.mli @@ -10,6 +10,4 @@ (* *) (***********************************************************************) -(* $Id: pos.mli 11156 2011-07-27 14:17:02Z doligez $ *) - val get_desc : Instruct.debug_event -> string;; diff --git a/debugger/primitives.ml b/debugger/primitives.ml index d259244e..8cbc5387 100644 --- a/debugger/primitives.ml +++ b/debugger/primitives.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: primitives.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (*********************** Basic functions and types *********************) (*** Miscellaneous ***) diff --git a/debugger/primitives.mli b/debugger/primitives.mli index ba994745..0e36b414 100644 --- a/debugger/primitives.mli +++ b/debugger/primitives.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: primitives.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (********************* Basic functions and types ***********************) (*** Miscellaneous ***) diff --git a/debugger/printval.ml b/debugger/printval.ml index ed9cf6ff..0fa2eced 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: printval.ml 12689 2012-07-10 14:54:19Z doligez $ *) - (* To print values *) open Format @@ -102,7 +100,7 @@ let print_named_value max_depth exp env obj ppf ty = let n = name_value obj ty in fprintf ppf "$%i" n in Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@." + fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@." print_value_name exp Printtyp.type_expr ty (print_value max_depth env obj) ty diff --git a/debugger/printval.mli b/debugger/printval.mli index 4cf65165..ba6c25ad 100644 --- a/debugger/printval.mli +++ b/debugger/printval.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: printval.mli 11156 2011-07-27 14:17:02Z doligez $ *) - open Format val max_printer_depth : int ref diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 7abaee85..99bfe6b4 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: program_loading.ml 12352 2012-04-13 12:43:24Z doligez $ *) - (* Program loading *) open Unix diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli index a4bba181..23ea47a6 100644 --- a/debugger/program_loading.mli +++ b/debugger/program_loading.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: program_loading.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (*** Debugging. ***) val debug_loading : bool ref diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 86525eed..c7438b39 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: program_management.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (* Manage the loading of the program *) open Int64ops diff --git a/debugger/program_management.mli b/debugger/program_management.mli index 03fe9fa7..0b8a09b8 100644 --- a/debugger/program_management.mli +++ b/debugger/program_management.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: program_management.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (*** Program loading and initializations. ***) val loaded : bool ref diff --git a/debugger/show_information.ml b/debugger/show_information.ml index bc119eb2..89111d3c 100644 --- a/debugger/show_information.ml +++ b/debugger/show_information.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: show_information.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Instruct open Format open Debugcom @@ -26,10 +24,10 @@ open Breakpoints (* Display information about the current event. *) let show_current_event ppf = - fprintf ppf "Time : %Li" (current_time ()); + fprintf ppf "Time: %Li" (current_time ()); (match current_pc () with | Some pc -> - fprintf ppf " - pc : %i" pc + fprintf ppf " - pc: %i" pc | _ -> ()); update_current_event (); reset_frame (); @@ -44,9 +42,9 @@ let show_current_event ppf = | [] -> () | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint + fprintf ppf "Breakpoint: %i@." breakpoint | breakpoints -> - fprintf ppf "Breakpoints : %a@." + fprintf ppf "Breakpoints: %a@." (fun ppf l -> List.iter (function x -> fprintf ppf "%i " x) l) @@ -75,7 +73,7 @@ let show_one_frame framenum ppf event = let buffer = get_buffer pos event.ev_module in snd (start_and_cnum buffer pos) with _ -> pos.Lexing.pos_cnum in - fprintf ppf "#%i Pc : %i %s char %i@." + fprintf ppf "#%i Pc: %i %s char %i@." framenum event.ev_pos event.ev_module cnum @@ -90,9 +88,9 @@ let show_current_frame ppf selected = begin match breakpoints_at_pc sel_ev.ev_pos with | [] -> () | [breakpoint] -> - fprintf ppf "Breakpoint : %i@." breakpoint + fprintf ppf "Breakpoint: %i@." breakpoint | breakpoints -> - fprintf ppf "Breakpoints : %a@." + fprintf ppf "Breakpoints: %a@." (fun ppf l -> List.iter (function x -> fprintf ppf "%i " x) l) (List.sort compare breakpoints); diff --git a/debugger/show_information.mli b/debugger/show_information.mli index 43f454b0..45329be4 100644 --- a/debugger/show_information.mli +++ b/debugger/show_information.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: show_information.mli 11156 2011-07-27 14:17:02Z doligez $ *) - open Format;; (* Display information about the current event. *) diff --git a/debugger/show_source.ml b/debugger/show_source.ml index 46ea5905..db2484f5 100644 --- a/debugger/show_source.ml +++ b/debugger/show_source.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: show_source.ml 11156 2011-07-27 14:17:02Z doligez $ *) - open Debugger_config open Instruct open Parameters @@ -77,7 +75,8 @@ let show_listing pos mdle start stop point before = let buffer = get_buffer pos mdle in let rec aff (line_start, line_number) = if line_number <= stop then - aff (print_line buffer line_number line_start point before + 1, line_number + 1) + aff (print_line buffer line_number line_start point before + 1, + line_number + 1) in aff (pos_of_line buffer start) with diff --git a/debugger/show_source.mli b/debugger/show_source.mli index b41a3ac0..c1aa204e 100644 --- a/debugger/show_source.mli +++ b/debugger/show_source.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: show_source.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Print the line containing the point *) val show_point : Instruct.debug_event -> bool -> unit;; @@ -20,4 +18,6 @@ val show_point : Instruct.debug_event -> bool -> unit;; val show_no_point : unit -> unit;; (* Display part of the source. *) -val show_listing : Lexing.position -> string -> int -> int -> int -> bool -> unit;; +val show_listing : + Lexing.position -> string -> int -> int -> int -> bool -> unit +;; diff --git a/debugger/source.ml b/debugger/source.ml index ecee85d3..c68df337 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: source.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (************************ Source management ****************************) open Misc @@ -43,7 +41,7 @@ let source_of_module pos mdle = let innermost_module = try let dot_index = String.rindex mdle '.' in - String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index)) + String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index)) with Not_found -> mdle in let rec loop = function diff --git a/debugger/source.mli b/debugger/source.mli index 75a7062e..640ebc85 100644 --- a/debugger/source.mli +++ b/debugger/source.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: source.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (************************ Source management ****************************) (*** Conversion function. ***) diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 3a7d9e5a..331d5bbd 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: symbols.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Handling of symbol tables (globals and events) *) open Instruct @@ -65,7 +63,8 @@ let read_symbols' bytecode_file = begin try ignore (Bytesections.seek_section ic "CODE") with Not_found -> - (* The file contains only debugging info, loading mode is forced to "manual" *) + (* The file contains only debugging info, + loading mode is forced to "manual" *) set_launching_function (List.assoc "manual" loading_modes) end; close_in_noerr ic; diff --git a/debugger/symbols.mli b/debugger/symbols.mli index 5a46b4a1..980892e0 100644 --- a/debugger/symbols.mli +++ b/debugger/symbols.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: symbols.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Modules used by the program. *) val modules : string list ref diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index 77b49a6a..c55c7540 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: time_travel.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (**************************** Time travel ******************************) open Int64ops @@ -94,7 +92,7 @@ let wait_for_connection checkpoint = (* Select a checkpoint as current. *) let set_current_checkpoint checkpoint = if !debug_time_travel then - prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid)); + prerr_endline ("Select: " ^ (string_of_int checkpoint.c_pid)); if not checkpoint.c_valid then wait_for_connection checkpoint; current_checkpoint := checkpoint; @@ -103,7 +101,7 @@ let set_current_checkpoint checkpoint = (* Kill `checkpoint'. *) let kill_checkpoint checkpoint = if !debug_time_travel then - prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid)); + prerr_endline ("Kill: " ^ (string_of_int checkpoint.c_pid)); if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *) (if not checkpoint.c_valid then wait_for_connection checkpoint; @@ -240,7 +238,7 @@ let duplicate_current_checkpoint () = Checkpoint_done pid -> (new_checkpoint.c_pid <- pid; if !debug_time_travel then - prerr_endline ("Waiting for connection : " ^ (string_of_int pid))) + prerr_endline ("Waiting for connection: " ^ string_of_int pid)) | Checkpoint_failed -> prerr_endline "A fork failed. Reducing maximum number of checkpoints."; @@ -326,7 +324,7 @@ let internal_step duration = set_current_checkpoint (find_checkpoint_before (current_time ())))); if !debug_time_travel then begin - print_string "Checkpoints : pid(time)"; print_newline (); + print_string "Checkpoints: pid(time)"; print_newline (); List.iter (function {c_time = time; c_pid = pid; c_valid = valid} -> Printf.printf "%d(%Ld)%s " pid time @@ -372,7 +370,7 @@ let set_file_descriptor pid fd = true) in if !debug_time_travel then - prerr_endline ("New connection : " ^(string_of_int pid)); + prerr_endline ("New connection: " ^(string_of_int pid)); find (!current_checkpoint::!checkpoints) (* Kill all the checkpoints. *) diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli index 0244f640..2d352320 100644 --- a/debugger/time_travel.mli +++ b/debugger/time_travel.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: time_travel.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (**************************** Time travel ******************************) open Primitives diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml index e7b859c5..ce5fe762 100644 --- a/debugger/trap_barrier.ml +++ b/debugger/trap_barrier.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: trap_barrier.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (************************** Trap barrier *******************************) open Debugcom diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli index 1d29c6ad..239c12a6 100644 --- a/debugger/trap_barrier.mli +++ b/debugger/trap_barrier.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: trap_barrier.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (************************* Trap barrier ********************************) val install_trap_barrier : int -> unit diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index e7a6949d..8cefd37e 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: unix_tools.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (****************** Tools for Unix *************************************) open Misc @@ -30,7 +28,7 @@ let convert_address address = ADDR_INET ((try inet_addr_of_string host with Failure _ -> try (gethostbyname host).h_addr_list.(0) with Not_found -> - prerr_endline ("Unknown host : " ^ host); + prerr_endline ("Unknown host: " ^ host); failwith "Can't convert address"), (try int_of_string port with Failure _ -> prerr_endline "The port number should be an integer"; @@ -43,14 +41,14 @@ let convert_address address = (*** Report a unix error. ***) let report_error = function | Unix_error (err, fun_name, arg) -> - prerr_string "Unix error : '"; + prerr_string "Unix error: '"; prerr_string fun_name; prerr_string "' failed"; if String.length arg > 0 then (prerr_string " on '"; prerr_string arg; prerr_string "'"); - prerr_string " : "; + prerr_string ": "; prerr_endline (error_message err) | _ -> fatal_error "report_error: not a Unix error" diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli index c2ee8a38..b1ac62db 100644 --- a/debugger/unix_tools.mli +++ b/debugger/unix_tools.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: unix_tools.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (**************************** Tools for Unix ***************************) open Unix diff --git a/driver/compenv.ml b/driver/compenv.ml new file mode 100644 index 00000000..c328e9c4 --- /dev/null +++ b/driver/compenv.ml @@ -0,0 +1,271 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Clflags + +let output_prefix name = + let oname = + match !output_name with + | None -> name + | Some n -> if !compile_only then (output_name := None; n) else name in + Misc.chop_extension_if_any oname + +let print_version_and_library compiler = + Printf.printf "The OCaml %s, version " compiler; + print_string Config.version; print_newline(); + print_string "Standard library directory: "; + print_string Config.standard_library; print_newline(); + exit 0 + +let print_version_string () = + print_string Config.version; print_newline(); exit 0 + +let print_standard_library () = + print_string Config.standard_library; print_newline(); exit 0 + +let fatal err = + prerr_endline err; + exit 2 + +let extract_output = function + | Some s -> s + | None -> + fatal "Please specify the name of the output file, using option -o" + +let default_output = function + | Some s -> s + | None -> Config.default_executable_name + +let implicit_modules = ref [] +let first_include_dirs = ref [] +let last_include_dirs = ref [] +let first_ccopts = ref [] +let last_ccopts = ref [] +let first_ppx = ref [] +let last_ppx = ref [] +let first_objfiles = ref [] +let last_objfiles = ref [] + +(* Note: this function is duplicated in optcompile.ml *) +let check_unit_name ppf filename name = + try + begin match name.[0] with + | 'A'..'Z' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + end; + for i = 1 to String.length name - 1 do + match name.[i] with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + done; + with Exit -> () +;; + + + + + + + +type readenv_position = + Before_args | Before_compile | Before_link + +(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)* + where VALUE should not contain ',' *) +exception SyntaxError of string + +let parse_args s = + let args = Misc.split s ',' in + let rec iter is_after args before after = + match args with + [] -> + if not is_after then + raise (SyntaxError "no '_' separator found") + else + (List.rev before, List.rev after) + | "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators") + | "_" :: tail -> iter true tail before after + | arg :: tail -> + let binding = try + Misc.cut_at arg '=' + with Not_found -> + raise (SyntaxError ("missing '=' in " ^ arg)) + in + if is_after then + iter is_after tail before (binding :: after) + else + iter is_after tail (binding :: before) after + in + iter false args [] [] + +let setter ppf f name options s = + try + let bool = match s with + | "0" -> false + | "1" -> true + | _ -> raise Not_found + in + List.iter (fun b -> b := f bool) options + with Not_found -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", + Printf.sprintf "bad value for %s" name)) + +let read_OCAMLPARAM ppf position = + try + let s = Sys.getenv "OCAMLPARAM" in + let (before, after) = + try + parse_args s + with SyntaxError s -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", s)); + [],[] + in + + let set name options s = setter ppf (fun b -> b) name options s in + let clear name options s = setter ppf (fun b -> not b) name options s in + List.iter (fun (name, v) -> + match name with + | "g" -> set "g" [ Clflags.debug ] v + | "p" -> set "p" [ Clflags.gprofile ] v + | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v + | "annot" -> set "annot" [ Clflags.annotations ] v + | "absname" -> set "absname" [ Location.absname ] v + | "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v + | "noassert" -> set "noassert" [ noassert ] v + | "noautolink" -> set "noautolink" [ no_auto_link ] v + | "nostdlib" -> set "nostdlib" [ no_std_include ] v + | "linkall" -> set "linkall" [ link_everything ] v + | "nolabels" -> set "nolabels" [ classic ] v + | "principal" -> set "principal" [ principal ] v + | "rectypes" -> set "rectypes" [ recursive_types ] v + | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v + | "thread" -> set "thread" [ use_threads ] v + | "unsafe" -> set "unsafe" [ fast ] v + | "verbose" -> set "verbose" [ verbose ] v + | "nopervasives" -> set "nopervasives" [ nopervasives ] v + | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *) + + | "compact" -> clear "compact" [ optimize_for_speed ] v + | "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v + | "nodynlink" -> clear "nodynlink" [ dlcode ] v + | "short-paths" -> clear "short-paths" [ real_paths ] v + + | "pp" -> preprocessor := Some v + | "runtime-variant" -> runtime_variant := v + | "cc" -> c_compiler := Some v + + (* assembly sources *) + | "s" -> + set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v + | "S" -> set "S" [ Clflags.keep_asm_file ] v + | "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v + + (* warn-errors *) + | "we" | "warn-error" -> Warnings.parse_options true v + (* warnings *) + | "w" -> Warnings.parse_options false v + (* warn-errors *) + | "wwe" -> Warnings.parse_options false v + + (* inlining *) + | "inline" -> begin try + inline_threshold := 8 * int_of_string v + with _ -> + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", + "non-integer parameter for \"inline\"")) + end + + | "intf-suffix" -> Config.interface_suffix := v + + | "I" -> begin + match position with + | Before_args -> first_include_dirs := v :: !first_include_dirs + | Before_link | Before_compile -> + last_include_dirs := v :: !last_include_dirs + end + + | "cclib" -> + begin + match position with + | Before_compile -> () + | Before_link | Before_args -> + ccobjs := Misc.rev_split_words v @ !ccobjs + end + + | "ccopts" -> + begin + match position with + | Before_link | Before_compile -> + last_ccopts := v :: !last_ccopts + | Before_args -> + first_ccopts := v :: !first_ccopts + end + + | "ppx" -> + begin + match position with + | Before_link | Before_compile -> + last_ppx := v :: !last_ppx + | Before_args -> + first_ppx := v :: !first_ppx + end + + + | "cmo" | "cma" -> + if not !native_code then + begin + match position with + | Before_link | Before_compile -> + last_objfiles := v ::! last_objfiles + | Before_args -> + first_objfiles := v :: !first_objfiles + end + + | "cmx" | "cmxa" -> + if !native_code then + begin + match position with + | Before_link | Before_compile -> + last_objfiles := v ::! last_objfiles + | Before_args -> + first_objfiles := v :: !first_objfiles + end + + | _ -> + Printf.eprintf + "Warning: discarding value of variable %S in OCAMLPARAM\n%!" + name + ) (match position with + Before_args -> before + | Before_compile | Before_link -> after) + with Not_found -> () + +let readenv ppf position = + last_include_dirs := []; + last_ccopts := []; + last_ppx := []; + last_objfiles := []; + read_OCAMLPARAM ppf position; + all_ccopts := !last_ccopts @ !first_ccopts; + all_ppx := !last_ppx @ !first_ppx + +let get_objfiles () = + List.rev (!last_objfiles @ !objfiles @ !first_objfiles) diff --git a/driver/compenv.mli b/driver/compenv.mli new file mode 100644 index 00000000..d1d64393 --- /dev/null +++ b/driver/compenv.mli @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +val check_unit_name : Format.formatter -> string -> string -> unit + +val output_prefix : string -> string +val extract_output : string option -> string +val default_output : string option -> string + +val print_version_and_library : string -> 'a +val print_version_string : unit -> 'a +val print_standard_library : unit -> 'a +val fatal : string -> 'a + +val first_ccopts : string list ref +val first_ppx : string list ref +val first_include_dirs : string list ref +val last_include_dirs : string list ref +val implicit_modules : string list ref + +(* return the list of objfiles, after OCAMLPARAM and List.rev *) +val get_objfiles : unit -> string list + +type readenv_position = + Before_args | Before_compile | Before_link + +val readenv : Format.formatter -> readenv_position -> unit diff --git a/driver/compile.ml b/driver/compile.ml index 501ca903..2e5b405d 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -10,93 +10,48 @@ (* *) (***********************************************************************) -(* $Id: compile.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (* The batch compiler *) open Misc open Config open Format open Typedtree - -(* Initialize the search path. - The current directory is always searched first, - then the directories specified with the -I option (in command-line order), - then the standard library directory (unless the -nostdlib option is given). - *) - -let init_path () = - let dirs = - if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs - else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs - else !Clflags.include_dirs in - let exp_dirs = - List.map (expand_directory Config.standard_library) dirs in - load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ()); - Env.reset_cache () - -(* Return the initial environment in which compilation proceeds. *) - -(* Note: do not do init_path() in initial_env, this breaks - toplevel initialization (PR#1775) *) -let initial_env () = - Ident.reinit(); - try - if !Clflags.nopervasives - then Env.initial - else Env.open_pers_signature "Pervasives" Env.initial - with Not_found -> - fatal_error "cannot open pervasives.cmi" - -(* Note: this function is duplicated in optcompile.ml *) -let check_unit_name ppf filename name = - try - begin match name.[0] with - | 'A'..'Z' -> () - | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); - raise Exit; - end; - for i = 1 to String.length name - 1 do - match name.[i] with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () - | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); - raise Exit; - done; - with Exit -> () -;; +open Compenv (* Compile a .mli file *) let interface ppf sourcefile outputprefix = Location.input_name := sourcefile; - init_path (); + Compmisc.init_path false; let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in - let initial_env = initial_env () in + let initial_env = Compmisc.initial_env () in try let ast = Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; + if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; let tsg = Typemod.transl_signature initial_env ast in + if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; + let sg = tsg.sig_type in if !Clflags.print_types then - fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature tsg.sig_type); + 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 sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in + let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in Typemod.save_signature modulename tsg outputprefix sourcefile - initial_env sg ; + initial_env sg ; end; Pparse.remove_preprocessed inputfile with e -> - Pparse.remove_preprocessed_if_ast inputfile; + Pparse.remove_preprocessed inputfile; raise e (* Compile a .ml file *) @@ -109,23 +64,26 @@ let (++) x f = f x let implementation ppf sourcefile outputprefix = Location.input_name := sourcefile; - init_path (); + Compmisc.init_path false; let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in - let env = initial_env() in + let env = Compmisc.initial_env() in if !Clflags.print_types then begin try ignore( Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile outputprefix modulename env); + ++ print_if ppf Clflags.dump_source Pprintast.structure + ++ Typemod.type_implementation sourcefile outputprefix modulename env + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion); Warnings.check_fatal (); Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); with x -> - Pparse.remove_preprocessed_if_ast inputfile; + Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); raise x end else begin @@ -134,7 +92,10 @@ let implementation ppf sourcefile outputprefix = try Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation + ++ print_if ppf Clflags.dump_source Pprintast.structure ++ Typemod.type_implementation sourcefile outputprefix modulename env + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion ++ Translmod.transl_implementation modulename ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda ++ Simplif.simplify_lambda @@ -149,7 +110,7 @@ let implementation ppf sourcefile outputprefix = with x -> close_out oc; remove_file objfile; - Pparse.remove_preprocessed_if_ast inputfile; + Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); raise x end diff --git a/driver/compile.mli b/driver/compile.mli index a4965a41..00f9029a 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: compile.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Compile a .ml or .mli file *) open Format @@ -19,6 +17,3 @@ open Format val interface: formatter -> string -> string -> unit val implementation: formatter -> string -> string -> unit val c_file: string -> unit - -val initial_env: unit -> Env.t -val init_path: unit -> unit diff --git a/driver/compmisc.ml b/driver/compmisc.ml new file mode 100644 index 00000000..8f974f4b --- /dev/null +++ b/driver/compmisc.ml @@ -0,0 +1,58 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Compenv + +(* Initialize the search path. + The current directory is always searched first, + then the directories specified with the -I option (in command-line order), + then the standard library directory (unless the -nostdlib option is given). + *) + +let init_path native = + let dirs = + if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs + else if !Clflags.use_vmthreads && not native then + "+vmthreads" :: !Clflags.include_dirs + else + !last_include_dirs @ + !Clflags.include_dirs @ + !first_include_dirs + in + let exp_dirs = + List.map (Misc.expand_directory Config.standard_library) dirs in + Config.load_path := "" :: + List.rev_append exp_dirs (Clflags.std_include_dir ()); + Env.reset_cache () + +(* Return the initial environment in which compilation proceeds. *) + +(* Note: do not do init_path() in initial_env, this breaks + toplevel initialization (PR#1775) *) + +let open_implicit_module m env = + try + Env.open_pers_signature m env + with Not_found -> + Misc.fatal_error (Printf.sprintf "cannot open implicit module %S" m) + +let initial_env () = + Ident.reinit(); + let env = + if !Clflags.nopervasives + then Env.initial + else + open_implicit_module "Pervasives" Env.initial + in + List.fold_left (fun env m -> + open_implicit_module m env + ) env !implicit_modules diff --git a/driver/compmisc.mli b/driver/compmisc.mli new file mode 100644 index 00000000..032e9fe4 --- /dev/null +++ b/driver/compmisc.mli @@ -0,0 +1,14 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +val init_path : bool -> unit +val initial_env : unit -> Env.t diff --git a/driver/errors.ml b/driver/errors.ml index b717ba2e..14a1a23c 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: errors.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (* WARNING: if you change something in this file, you must look at opterrors.ml and ocamldoc/odoc_analyse.ml to see if you need to make the same changes there. @@ -28,9 +26,8 @@ let report_error ppf exn = Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err - | Pparse.Error -> - Location.print_error_cur_file ppf; - fprintf ppf "Preprocessor error" + | Pparse.Error err -> + Pparse.report_error ppf err | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err @@ -42,19 +39,19 @@ let report_error ppf exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> @@ -78,7 +75,7 @@ let report_error ppf exn = fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/errors.mli b/driver/errors.mli index faff2a48..c9f1ee95 100644 --- a/driver/errors.mli +++ b/driver/errors.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: errors.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Error report *) open Format diff --git a/driver/main.ml b/driver/main.ml index e0f5e0c9..4ab251c7 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -10,17 +10,9 @@ (* *) (***********************************************************************) -(* $Id: main.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - open Config open Clflags - -let output_prefix name = - let oname = - match !output_name with - | None -> name - | Some n -> if !compile_only then (output_name := None; n) else name in - Misc.chop_extension_if_any oname +open Compenv let process_interface_file ppf name = Compile.interface ppf name (output_prefix name) @@ -60,27 +52,17 @@ let process_file ppf name = else raise(Arg.Bad("don't know what to do with " ^ name)) -let print_version_and_library () = - print_string "The OCaml compiler, version "; - print_string Config.version; print_newline(); - print_string "Standard library directory: "; - print_string Config.standard_library; print_newline(); - exit 0 - -let print_version_string () = - print_string Config.version; print_newline(); exit 0 - -let print_standard_library () = - print_string Config.standard_library; print_newline(); exit 0 - let usage = "Usage: ocamlc \nOptions are:" let ppf = Format.err_formatter (* Error messages to standard error formatter *) -let anonymous = process_file ppf;; -let impl = process_implementation_file ppf;; -let intf = process_interface_file ppf;; +let anonymous filename = + readenv ppf Before_compile; process_file ppf filename;; +let impl filename = + readenv ppf Before_compile; process_implementation_file ppf filename;; +let intf filename = + readenv ppf Before_compile; process_interface_file ppf filename;; let show_config () = Config.print_config stdout; @@ -97,7 +79,8 @@ module Options = Main_args.Make_bytecomp_options (struct let _c = set compile_only let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs - let _ccopt s = ccopts := s :: !ccopts + let _ccopt s = first_ccopts := s :: !first_ccopts + let _compat_32 = set bytecode_compatible_32 let _config = show_config let _custom = set custom_runtime let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs @@ -121,16 +104,18 @@ module Options = Main_args.Make_bytecomp_options (struct let _output_obj () = output_c_object := true; custom_runtime := true let _pack = set make_package let _pp s = preprocessor := Some s + let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _short_paths = unset real_paths let _strict_sequence = set strict_sequence let _thread = set use_threads let _vmthread = set use_vmthreads let _unsafe = set fast let _use_prims s = use_prims := s let _use_runtime s = use_runtime := s - let _v = print_version_and_library + let _v () = print_version_and_library "compiler" let _version = print_version_string let _vnum = print_version_string let _w = (Warnings.parse_options false) @@ -139,28 +124,20 @@ module Options = Main_args.Make_bytecomp_options (struct let _where = print_standard_library let _verbose = set verbose let _nopervasives = set nopervasives + let _dsource = set dump_source let _dparsetree = set dump_parsetree + let _dtypedtree = set dump_typedtree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda let _dinstr = set dump_instr let anonymous = anonymous end) -let fatal err = - prerr_endline err; - exit 2 - -let extract_output = function - | Some s -> s - | None -> fatal "Please specify the name of the output file, using option -o" - -let default_output = function - | Some s -> s - | None -> Config.default_executable_name - let main () = try + readenv ppf Before_args; Arg.parse Options.list anonymous usage; + readenv ppf Before_link; if List.length (List.filter (fun x -> !x) [make_archive;make_package;compile_only;output_c_object]) @@ -171,16 +148,16 @@ let main () = else fatal "Please specify at most one of -pack, -a, -c, -output-obj"; if !make_archive then begin - Compile.init_path(); + Compmisc.init_path false; - Bytelibrarian.create_archive ppf (List.rev !objfiles) + Bytelibrarian.create_archive ppf (Compenv.get_objfiles ()) (extract_output !output_name); Warnings.check_fatal (); end else if !make_package then begin - Compile.init_path(); + Compmisc.init_path false; let extracted_output = extract_output !output_name in - let revd = List.rev !objfiles in + let revd = get_objfiles () in Bytepackager.package_files ppf revd (extracted_output); Warnings.check_fatal (); end @@ -201,8 +178,8 @@ let main () = else default_output !output_name in - Compile.init_path(); - Bytelink.link ppf (List.rev !objfiles) target; + Compmisc.init_path false; + Bytelink.link ppf (get_objfiles ()) target; Warnings.check_fatal (); end; exit 0 diff --git a/driver/main.mli b/driver/main.mli index 56b54a16..b2176ff9 100644 --- a/driver/main.mli +++ b/driver/main.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: main.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* this "empty" file is here to speed up garbage collection in ocamlc.opt *) diff --git a/driver/main_args.ml b/driver/main_args.ml index 567afe1d..237e7370 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -10,14 +10,12 @@ (* *) (***********************************************************************) -(* $Id: main_args.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - let mk_a f = "-a", Arg.Unit f, " Build a library" ;; let mk_absname f = - "-absname", Arg.Unit f, " Show absolute filenames in error message" + "-absname", Arg.Unit f, " Show absolute filenames in error messages" ;; let mk_annot f = @@ -41,13 +39,19 @@ let mk_cclib f = ;; let mk_ccopt f = - "-ccopt", Arg.String f, " Pass option to the C compiler and linker" + "-ccopt", Arg.String f, + " Pass option to the C compiler and linker" ;; let mk_compact f = "-compact", Arg.Unit f, " Optimize code size rather than speed" ;; +let mk_compat_32 f = + "-compat-32", Arg.Unit f, + " Check that generated bytecode can run on 32-bit platforms" +;; + let mk_config f = "-config", Arg.Unit f, " Print configuration values and exit" ;; @@ -209,6 +213,11 @@ let mk_pp f = "-pp", Arg.String f, " Pipe sources through preprocessor " ;; +let mk_ppx f = + "-ppx", Arg.String f, + " Pipe abstract syntax trees through preprocessor " +;; + let mk_principal f = "-principal", Arg.Unit f, " Check principality of type inference" ;; @@ -226,6 +235,10 @@ let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; +let mk_short_paths f = + "-short-paths", Arg.Unit f, " Shorten paths in types" +;; + let mk_stdin f = "-stdin", Arg.Unit f, " Read script from standard input" ;; @@ -264,24 +277,24 @@ let mk_v f = " Print compiler version and location of standard library and exit" ;; -let mk_version f = - "-version", Arg.Unit f, " Print version and exit" -;; - -let mk_vnum f = - "-vnum", Arg.Unit f, " Print version number and exit" -;; - let mk_verbose f = "-verbose", Arg.Unit f, " Print calls to external commands" ;; +let mk_version f = + "-version", Arg.Unit f, " Print version and exit" +;; + let mk_vmthread f = "-vmthread", Arg.Unit f, " Generate code that supports the threads library with VM-level\n\ \ scheduling" ;; +let mk_vnum f = + "-vnum", Arg.Unit f, " Print version number and exit" +;; + let mk_w f = "-w", Arg.String f, Printf.sprintf @@ -305,7 +318,7 @@ let mk_warn_error f = ;; let mk_warn_help f = - "-warn-help", Arg.Unit f, " Show description of warning numbers" + "-warn-help", Arg.Unit f, " Show description of warning numbers" ;; let mk_where f = @@ -324,10 +337,18 @@ let mk_dparsetree f = "-dparsetree", Arg.Unit f, " (undocumented)" ;; +let mk_dtypedtree f = + "-dtypedtree", Arg.Unit f, " (undocumented)" +;; + let mk_drawlambda f = "-drawlambda", Arg.Unit f, " (undocumented)" ;; +let mk_dsource f = + "-dsource", Arg.Unit f, " (undocumented)" +;; + let mk_dlambda f = "-dlambda", Arg.Unit f, " (undocumented)" ;; @@ -406,6 +427,7 @@ module type Bytecomp_options = sig val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit + val _compat_32 : unit -> unit val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit @@ -428,9 +450,11 @@ module type Bytecomp_options = sig val _output_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _short_paths : unit -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -447,7 +471,9 @@ module type Bytecomp_options = sig val _nopervasives : unit -> unit val _use_prims : string -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit @@ -466,8 +492,10 @@ module type Bytetop_options = sig val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _short_paths : unit -> unit val _stdin: unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -477,7 +505,9 @@ module type Bytetop_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit @@ -517,25 +547,29 @@ module type Optcomp_options = sig val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit - val _strict_sequence : unit -> unit val _shared : unit -> unit + val _short_paths : unit -> unit + val _strict_sequence : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit + val _verbose : unit -> unit val _version : unit -> unit val _vnum : unit -> unit - val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit @@ -569,9 +603,11 @@ module type Opttop_options = sig val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -581,7 +617,9 @@ module type Opttop_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit @@ -617,6 +655,7 @@ struct mk_cc F._cc; mk_cclib F._cclib; mk_ccopt F._ccopt; + mk_compat_32 F._compat_32; mk_config F._config; mk_custom F._custom; mk_dllib F._dllib; @@ -644,19 +683,21 @@ struct mk_output_obj F._output_obj; mk_pack_byt F._pack; mk_pp F._pp; + mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; + mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; mk_use_runtime F._use_runtime; mk_use_runtime_2 F._use_runtime; mk_v F._v; - mk_version F._version; - mk_vnum F._vnum; mk_verbose F._verbose; + mk_version F._version; mk_vmthread F._vmthread; + mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; @@ -664,7 +705,9 @@ struct mk_nopervasives F._nopervasives; mk_use_prims F._use_prims; + mk_dsource F._dsource; mk_dparsetree F._dparsetree; + mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; @@ -686,8 +729,10 @@ struct mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; + mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; + mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; @@ -697,7 +742,9 @@ struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk_dsource F._dsource; mk_dparsetree F._dparsetree; + mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; @@ -741,25 +788,29 @@ struct mk_p F._p; mk_pack_opt F._pack; mk_pp F._pp; + mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_S F._S; - mk_strict_sequence F._strict_sequence; mk_shared F._shared; + mk_short_paths F._short_paths; + mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; mk_v F._v; + mk_verbose F._verbose; mk_version F._version; mk_vnum F._vnum; - mk_verbose F._verbose; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; mk_nopervasives F._nopervasives; + mk_dsource F._dsource; mk_dparsetree F._dparsetree; + mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dclambda F._dclambda; @@ -795,9 +846,11 @@ module Make_opttop_options (F : Opttop_options) = struct mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; + mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; mk_S F._S; + mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; @@ -807,7 +860,9 @@ module Make_opttop_options (F : Opttop_options) = struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk_dsource F._dsource; mk_dparsetree F._dparsetree; + mk_dtypedtree F._dtypedtree; mk_drawlambda F._drawlambda; mk_dclambda F._dclambda; mk_dcmm F._dcmm; diff --git a/driver/main_args.mli b/driver/main_args.mli index 2cc30155..53647236 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: main_args.mli 12511 2012-05-30 13:29:48Z lefessan $ *) - module type Bytecomp_options = sig val _a : unit -> unit @@ -22,6 +20,7 @@ module type Bytecomp_options = val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit + val _compat_32 : unit -> unit val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit @@ -44,9 +43,11 @@ module type Bytecomp_options = val _output_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _short_paths : unit -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -63,7 +64,9 @@ module type Bytecomp_options = val _nopervasives : unit -> unit val _use_prims : string -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit @@ -83,8 +86,10 @@ module type Bytetop_options = sig val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -94,7 +99,9 @@ module type Bytetop_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit @@ -134,25 +141,29 @@ module type Optcomp_options = sig val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit - val _strict_sequence : unit -> unit val _shared : unit -> unit + val _short_paths : unit -> unit + val _strict_sequence : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit + val _verbose : unit -> unit val _version : unit -> unit val _vnum : unit -> unit - val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit @@ -186,9 +197,11 @@ module type Opttop_options = sig val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -198,7 +211,9 @@ module type Opttop_options = sig val _warn_error : string -> unit val _warn_help : unit -> unit + val _dsource : unit -> unit val _dparsetree : unit -> unit + val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 7cd18677..ebe2457c 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -10,90 +10,48 @@ (* *) (***********************************************************************) -(* $Id: optcompile.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (* The batch compiler *) open Misc open Config open Format open Typedtree - -(* Initialize the search path. - The current directory is always searched first, - then the directories specified with the -I option (in command-line order), - then the standard library directory. *) - -let init_path () = - let dirs = - if !Clflags.use_threads - then "+threads" :: !Clflags.include_dirs - else !Clflags.include_dirs in - let exp_dirs = - List.map (expand_directory Config.standard_library) dirs in - load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ()); - Env.reset_cache () - -(* Return the initial environment in which compilation proceeds. *) - -let initial_env () = - Ident.reinit(); - try - if !Clflags.nopervasives - then Env.initial - else Env.open_pers_signature "Pervasives" Env.initial - with Not_found -> - fatal_error "cannot open pervasives.cmi" - -(* Note: this function is duplicated in compile.ml *) -let check_unit_name ppf filename name = - try - begin match name.[0] with - | 'A'..'Z' -> () - | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); - raise Exit; - end; - for i = 1 to String.length name - 1 do - match name.[i] with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () - | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); - raise Exit; - done; - with Exit -> () -;; +open Compenv (* Compile a .mli file *) let interface ppf sourcefile outputprefix = Location.input_name := sourcefile; - init_path (); + Compmisc.init_path true; let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in - let initial_env = initial_env() in + let initial_env = Compmisc.initial_env() in try let ast = Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; + if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; let tsg = Typemod.transl_signature initial_env ast in + if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; + let sg = tsg.sig_type in if !Clflags.print_types then fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature tsg.sig_type); + (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 sg = Env.save_signature tsg.sig_type modulename (outputprefix ^ ".cmi") in - Typemod.save_signature modulename tsg outputprefix sourcefile initial_env sg ; + let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in + Typemod.save_signature modulename tsg outputprefix sourcefile + initial_env sg ; end; Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")) with e -> - Pparse.remove_preprocessed_if_ast inputfile; + Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); raise e @@ -108,25 +66,31 @@ let (+++) (x, y) f = (x, f y) let implementation ppf sourcefile outputprefix = Location.input_name := sourcefile; - init_path (); + Compmisc.init_path true; let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in - let env = initial_env() in + let env = Compmisc.initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; let cmxfile = outputprefix ^ ".cmx" in let objfile = outputprefix ^ ext_obj in try - if !Clflags.print_types then ignore( + if !Clflags.print_types then ignore begin Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ Typemod.type_implementation sourcefile outputprefix modulename env) - else begin + ++ print_if ppf Clflags.dump_source Pprintast.structure + ++ Typemod.type_implementation sourcefile outputprefix modulename env + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion + end else begin Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number ++ print_if ppf Clflags.dump_parsetree Printast.implementation + ++ print_if ppf Clflags.dump_source Pprintast.structure ++ Typemod.type_implementation sourcefile outputprefix modulename env + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion ++ Translmod.transl_store_implementation modulename +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda +++ Simplif.simplify_lambda @@ -140,7 +104,7 @@ let implementation ppf sourcefile outputprefix = with x -> remove_file objfile; remove_file cmxfile; - Pparse.remove_preprocessed_if_ast inputfile; + Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); raise x diff --git a/driver/optcompile.mli b/driver/optcompile.mli index d1e3f6b5..00f9029a 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: optcompile.mli 12058 2012-01-20 14:23:34Z frisch $ *) - (* Compile a .ml or .mli file *) open Format @@ -19,6 +17,3 @@ open Format val interface: formatter -> string -> string -> unit val implementation: formatter -> string -> string -> unit val c_file: string -> unit - -val initial_env: unit -> Env.t -val init_path: unit -> unit diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 04ea7dd3..56660cdb 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: opterrors.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - (* WARNING: if you change something in this file, you must look at errors.ml to see if you need to make the same changes there. *) @@ -27,9 +25,8 @@ let report_error ppf exn = Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err - | Pparse.Error -> - Location.print_error_cur_file ppf; - fprintf ppf "Preprocessor error" + | Pparse.Error err -> + Pparse.report_error ppf err | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err @@ -41,19 +38,19 @@ let report_error ppf exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> @@ -80,7 +77,7 @@ let report_error ppf exn = fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/opterrors.mli b/driver/opterrors.mli index c2d8dccc..6267091b 100644 --- a/driver/opterrors.mli +++ b/driver/opterrors.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: opterrors.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Error report *) val report_error: Format.formatter -> exn -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 108c1bea..45bdec24 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -10,17 +10,9 @@ (* *) (***********************************************************************) -(* $Id: optmain.ml 12511 2012-05-30 13:29:48Z lefessan $ *) - open Config open Clflags - -let output_prefix name = - let oname = - match !output_name with - | None -> name - | Some n -> if !compile_only then (output_name := None; n) else name in - Misc.chop_extension_if_any oname +open Compenv let process_interface_file ppf name = Optcompile.interface ppf name (output_prefix name) @@ -59,38 +51,17 @@ let process_file ppf name = else raise(Arg.Bad("don't know what to do with " ^ name)) -let print_version_and_library () = - print_string "The OCaml native-code compiler, version "; - print_string Config.version; print_newline(); - print_string "Standard library directory: "; - print_string Config.standard_library; print_newline(); - exit 0 - -let print_version_string () = - print_string Config.version; print_newline(); exit 0 - -let print_standard_library () = - print_string Config.standard_library; print_newline(); exit 0 - -let fatal err = - prerr_endline err; - exit 2 - -let extract_output = function - | Some s -> s - | None -> - fatal "Please specify the name of the output file, using option -o" - -let default_output = function - | Some s -> s - | None -> Config.default_executable_name - let usage = "Usage: ocamlopt \nOptions are:" +let ppf = Format.err_formatter + (* Error messages to standard error formatter *) -let anonymous = process_file Format.err_formatter;; -let impl = process_implementation_file Format.err_formatter;; -let intf = process_interface_file Format.err_formatter;; +let anonymous filename = + readenv ppf Before_compile; process_file ppf filename;; +let impl filename = + readenv ppf Before_compile; process_implementation_file ppf filename;; +let intf filename = + readenv ppf Before_compile; process_interface_file ppf filename;; let show_config () = Config.print_config stdout; @@ -108,7 +79,7 @@ module Options = Main_args.Make_optcomp_options (struct let _c = set compile_only let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs - let _ccopt s = ccopts := s :: !ccopts + let _ccopt s = first_ccopts := s :: !first_ccopts let _compact = clear optimize_for_speed let _config () = show_config () let _for_pack s = for_package := Some s @@ -132,15 +103,17 @@ module Options = Main_args.Make_optcomp_options (struct let _p = set gprofile let _pack = set make_package let _pp s = preprocessor := Some s + let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _short_paths = clear real_paths let _strict_sequence = set strict_sequence let _shared () = shared := true; dlcode := true let _S = set keep_asm_file let _thread = set use_threads let _unsafe = set fast - let _v () = print_version_and_library () + let _v () = print_version_and_library "native-code compiler" let _version () = print_version_string () let _vnum () = print_version_string () let _verbose = set verbose @@ -150,7 +123,9 @@ module Options = Main_args.Make_optcomp_options (struct let _where () = print_standard_library () let _nopervasives = set nopervasives + let _dsource = set dump_source let _dparsetree = set dump_parsetree + let _dtypedtree = set dump_typedtree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda let _dclambda = set dump_clambda @@ -175,7 +150,9 @@ let main () = native_code := true; let ppf = Format.err_formatter in try + readenv ppf Before_args; Arg.parse (Arch.command_line_options @ Options.list) anonymous usage; + readenv ppf Before_link; if List.length (List.filter (fun x -> !x) [make_package; make_archive; shared; @@ -185,21 +162,21 @@ let main () = if !make_archive then begin if !cmxa_present then fatal "Option -a cannot be used with .cmxa input files."; - Optcompile.init_path(); + Compmisc.init_path true; let target = extract_output !output_name in - Asmlibrarian.create_archive (List.rev !objfiles) target; + Asmlibrarian.create_archive (get_objfiles ()) target; Warnings.check_fatal (); end else if !make_package then begin - Optcompile.init_path(); + Compmisc.init_path true; let target = extract_output !output_name in - Asmpackager.package_files ppf (List.rev !objfiles) target; + Asmpackager.package_files ppf (get_objfiles ()) target; Warnings.check_fatal (); end else if !shared then begin - Optcompile.init_path(); + Compmisc.init_path true; let target = extract_output !output_name in - Asmlink.link_shared ppf (List.rev !objfiles) target; + Asmlink.link_shared ppf (get_objfiles ()) target; Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin @@ -218,8 +195,8 @@ let main () = else default_output !output_name in - Optcompile.init_path(); - Asmlink.link ppf (List.rev !objfiles) target; + Compmisc.init_path true; + Asmlink.link ppf (get_objfiles ()) target; Warnings.check_fatal (); end; exit 0 diff --git a/driver/optmain.mli b/driver/optmain.mli index 43b1965d..d43cb760 100644 --- a/driver/optmain.mli +++ b/driver/optmain.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: optmain.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* this "empty" file is here to speed up garbage collection in ocamlopt.opt *) diff --git a/driver/pparse.ml b/driver/pparse.ml index 0ea62f35..57b564f0 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -10,11 +10,13 @@ (* *) (***********************************************************************) -(* $Id: pparse.ml 12387 2012-04-20 15:33:56Z doligez $ *) - open Format -exception Error +type error = + | CannotRun of string + | WrongMagic of string + +exception Error of error (* Optionally preprocess a source file *) @@ -28,7 +30,7 @@ let preprocess sourcefile = in if Ccomp.command comm <> 0 then begin Misc.remove_file tmpfile; - raise Error; + raise (Error (CannotRun comm)); end; tmpfile @@ -37,13 +39,62 @@ let remove_preprocessed inputfile = None -> () | Some _ -> Misc.remove_file inputfile -let remove_preprocessed_if_ast inputfile = - match !Clflags.preprocessor with - None -> () - | Some _ -> - if inputfile <> !Location.input_name then Misc.remove_file inputfile +let write_ast magic ast = + let fn = Filename.temp_file "camlppx" "" in + let oc = open_out_bin fn in + output_string oc magic; + output_value oc !Location.input_name; + output_value oc ast; + close_out oc; + fn + +let apply_rewriter magic fn_in ppx = + let fn_out = Filename.temp_file "camlppx" "" in + let comm = + Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) + in + let ok = Ccomp.command comm = 0 in + Misc.remove_file fn_in; + if not ok then begin + Misc.remove_file fn_out; + raise (Error (CannotRun comm)); + end; + if not (Sys.file_exists fn_out) then raise (Error (WrongMagic comm)); + (* check magic before passing to the next ppx *) + let ic = open_in_bin fn_out in + let buffer = + try Misc.input_bytes ic (String.length magic) with End_of_file -> "" in + close_in ic; + if buffer <> magic then begin + Misc.remove_file fn_out; + raise (Error (WrongMagic comm)); + end; + fn_out + +let read_ast magic fn = + let ic = open_in_bin fn in + try + let buffer = Misc.input_bytes ic (String.length magic) in + assert(buffer = magic); (* already checked by apply_rewriter *) + Location.input_name := input_value ic; + let ast = input_value ic in + close_in ic; + Misc.remove_file fn; + ast + with exn -> + close_in ic; + Misc.remove_file fn; + raise exn -(* Parse a file or get a dumped syntax tree in it *) +let apply_rewriters magic ast = + match !Clflags.all_ppx with + | [] -> ast + | ppxs -> + let fn = + List.fold_left (apply_rewriter magic) (write_ast magic ast) ppxs in + read_ast magic fn + +(* Parse a file or get a dumped syntax tree from it *) exception Outdated_version @@ -65,6 +116,7 @@ let file ppf inputfile parse_fun ast_magic = try if is_ast_file then begin if !Clflags.fast then + (* FIXME make this a proper warning *) fprintf ppf "@[Warning: %s@]@." "option -unsafe used with a preprocessor returning a syntax tree"; Location.input_name := input_value ic; @@ -79,4 +131,12 @@ let file ppf inputfile parse_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - ast + apply_rewriters ast_magic ast + +let report_error ppf = function + | CannotRun cmd -> + fprintf ppf "Error while running external preprocessor@.\ + Command line: %s@." cmd + | WrongMagic cmd -> + fprintf ppf "External preprocessor does not produce a valid file@.\ + Command line: %s@." cmd diff --git a/driver/pparse.mli b/driver/pparse.mli index 754f5f24..43e3d5f8 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -10,13 +10,16 @@ (* *) (***********************************************************************) -(* $Id: pparse.mli 12058 2012-01-20 14:23:34Z frisch $ *) - open Format -exception Error +type error = + | CannotRun of string + | WrongMagic of string + +exception Error of error val preprocess : string -> string val remove_preprocessed : string -> unit -val remove_preprocessed_if_ast : string -> unit val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a +val apply_rewriters : string -> 'a -> 'a +val report_error : formatter -> error -> unit diff --git a/emacs/.ignore b/emacs/.ignore index ea6381f9..ba5f96cd 100644 --- a/emacs/.ignore +++ b/emacs/.ignore @@ -1 +1,2 @@ ocamltags +*.elc diff --git a/emacs/Makefile b/emacs/Makefile index e01c34f6..22b2a19b 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile 12118 2012-02-03 16:04:49Z doligez $ - include ../config/Makefile # Files to install @@ -37,6 +35,7 @@ COMPILECMD=(progn \ (byte-compile-file "inf-caml.el") \ (byte-compile-file "caml-help.el") \ (byte-compile-file "caml-types.el") \ + (byte-compile-file "caml-font.el") \ (byte-compile-file "camldebug.el")) install: @@ -80,4 +79,4 @@ compile-only: $(EMACS) --batch --eval '$(COMPILECMD)' clean: - rm -f ocamltags *~ #*# *.elc + rm -f ocamltags *~ \#*# *.elc diff --git a/emacs/README b/emacs/README index 0ec8e3e9..9c30c889 100644 --- a/emacs/README +++ b/emacs/README @@ -1,4 +1,4 @@ - OCaml emacs mode, snapshot of $Date: 2012-02-10 17:15:24 +0100 (Fri, 10 Feb 2012) $ + OCaml emacs mode, snapshot of $Date$ The files in this archive define a caml-mode for emacs, for editing OCaml and Objective Label programs, as well as an diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el index a0edfd83..a5cff879 100644 --- a/emacs/caml-compat.el +++ b/emacs/caml-compat.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-compat.el 11156 2011-07-27 14:17:02Z doligez $ *) - ;; function definitions for old versions of emacs ;; indent-line-to diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el index b9a7fabc..7166d1a8 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-emacs.el 11156 2011-07-27 14:17:02Z doligez $ *) - ;; for caml-help.el (defalias 'caml-info-other-window 'info-other-window) @@ -27,7 +25,7 @@ (defalias 'caml-mouse-movement-p 'mouse-movement-p) (defalias 'caml-sit-for 'sit-for) -(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body)) +(defalias 'caml-track-mouse 'track-mouse) (defun caml-event-window (e) (posn-window (event-start e))) (defun caml-event-point-start (e) (posn-point (event-start e))) @@ -39,8 +37,7 @@ (or (member 'drag modifiers) (member 'click modifiers))))) -(if (fboundp 'string-to-number) - (defalias 'caml-string-to-int 'string-to-number) - (defalias 'caml-string-to-int 'string-to-int)) +(defalias 'caml-string-to-int (if (fboundp 'string-to-number) + 'string-to-number 'string-to-int)) (provide 'caml-emacs) diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el index b48c0be5..7456e8c5 100644 --- a/emacs/caml-font-old.el +++ b/emacs/caml-font-old.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-font-old.el 11156 2011-07-27 14:17:02Z doligez $ *) - ;; useful colors (cond diff --git a/emacs/caml-font.el b/emacs/caml-font.el index d0eeb5c8..40bee0a3 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -1,3 +1,15 @@ +;(***********************************************************************) +;(* *) +;(* OCaml *) +;(* *) +;(* Jacques Garrigue, Ian T Zimmerman, Damien Doligez *) +;(* *) +;(* 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-font: font-lock support for OCaml files ;; now with perfect parsing of comments and strings @@ -128,11 +140,13 @@ (defconst caml-font-ident-re - "[A-Za-z_\300-\326\330-\366\370-\377][A-Za-z_\300-\326\330-\366\370-\377'0-9]*" + (concat "[A-Za-z_\300-\326\330-\366\370-\377]" + "[A-Za-z_\300-\326\330-\366\370-\377'0-9]*") ) (defconst caml-font-int-re - "\\(0[xX][0-9A-Fa-f][0-9A-Fa-f_]*\\|0[oO][0-7][0-7_]*\\|0[bB][01][01_]*\\)[lLn]?" + (concat "\\(0[xX][0-9A-Fa-f][0-9A-Fa-f_]*\\|0[oO][0-7][0-7_]*" + "\\|0[bB][01][01_]*\\)[lLn]?") ) ; decimal integers are folded into the RE for floats to get longest-match @@ -148,7 +162,9 @@ ; match any char token (defconst caml-font-char-re - "'\\(\015\012\\|[^\\']\\|\\(\\\\\\([\\'\"ntbr ]\\|[0-9][0-9][0-9]\\|x[0-9A-Fa-f][0-9A-Fa-f]\\)\\)\\)'" + (concat "'\\(\015\012\\|[^\\']\\|" + "\\(\\\\\\([\\'\"ntbr ]\\|[0-9][0-9][0-9]" + "\\|x[0-9A-Fa-f][0-9A-Fa-f]\\)\\)\\)'") ) ; match a quote followed by a newline diff --git a/emacs/caml-help.el b/emacs/caml-help.el index 73497566..82defadc 100644 --- a/emacs/caml-help.el +++ b/emacs/caml-help.el @@ -1,3 +1,4 @@ +;;; caml-help.el --- Contextual completion and help to caml-mode ;(***********************************************************************) ;(* *) ;(* OCaml *) @@ -10,14 +11,12 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-help.el 11156 2011-07-27 14:17:02Z doligez $ *) +;; Author: Didier Remy, November 2001. -;; caml-info.el --- contextual completion and help to caml-mode +;;; Commentary: -;; Didier Remy, November 2001. - -;; This provides two functions completion and help -;; look for caml-complete and caml-help +;; This provides two functions: completion and help. +;; Look for caml-complete and caml-help. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -34,15 +33,16 @@ ;; - the viewing method and the database, so that the documentation for ;; and identifier could be search in ;; * info / html / man / mli's sources -;; * viewed in emacs or using an external previewer. +;; * viewed in Emacs or using an external previewer. ;; ;; Take all identifiers (labels, Constructors, exceptions, etc.) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code: (eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) + (if (featurep 'xemacs) (require 'caml-xemacs) (require 'caml-emacs))) @@ -52,11 +52,11 @@ ;; variables to be customized (defvar ocaml-lib-path 'lazy - "Path list for ocaml lib sources (mli files) + "Path list for ocaml lib sources (mli files). -'lazy means ask ocaml to find it for your at first use.") +`lazy' means ask ocaml to find it for your at first use.") (defun ocaml-lib-path () - "Computes if necessary and returns the path for ocaml libs" + "Compute if necessary and return the path for ocaml libs." (if (listp ocaml-lib-path) nil (setq ocaml-lib-path (split-string @@ -85,13 +85,11 @@ (concat (downcase (substring s 0 1)) (substring s 1)) s)) -(defun iter (f l) (while (consp l) (apply f (list (car l))) (setq l (cdr l)))) - (defun ocaml-find-files (path filter &optional depth split) (let* ((path-string (if (stringp path) (if (file-directory-p path) path nil) - (mapconcat '(lambda (d) (if (file-directory-p d) d)) + (mapconcat (lambda (d) (if (file-directory-p d) d)) path " "))) (command (and path-string @@ -112,7 +110,7 @@ (defvar ocaml-module-alist 'lazy "A-list of modules with how and where to find help information. - 'delay means non computed yet") +`delay' means non computed yet.") (defun ocaml-add-mli-modules (modules tag &optional path) (let ((files @@ -133,13 +131,13 @@ modules)) (defun ocaml-add-path (dir &optional path) - "Extend ocaml-module-alist with modules of DIR relative to PATH" + "Extend `ocaml-module-alist' with modules of DIR relative to PATH." (interactive "D") (let* ((old (ocaml-lib-path)) (new (if (file-name-absolute-p dir) dir (concat - (or (find-if '(lambda (p) (file-directory-p (concat p "/" dir))) + (or (find-if (lambda (p) (file-directory-p (concat p "/" dir))) (cons default-directory old)) (error "Directory not found")) "/" dir)))) @@ -148,7 +146,7 @@ (ocaml-add-mli-modules (ocaml-module-alist) 'lib new)))) (defun ocaml-module-alist () - "Call by need value of variable ocaml-module-alist" + "Call by need value of variable `ocaml-module-alist'." (if (listp ocaml-module-alist) nil ;; build list of mli files @@ -251,7 +249,7 @@ When call interactively, make completion over known modules." (defun ocaml-close-module (arg) "*Close module of name ARG when ARG is a string. When call interactively, make completion over visible modules. -Otherwise if ARG is true, close all modules and reset to default. " +Otherwise if ARG is true, close all modules and reset to default." (interactive "P") (if (= (prefix-numeric-value arg) 4) (setq ocaml-visible-modules 'lazy) @@ -264,7 +262,7 @@ Otherwise if ARG is true, close all modules and reset to default. " modules)) (if (equal arg "") (setq arg (caar modules)))) (setq ocaml-visible-modules - (remove-if '(lambda (m) (equal (car m) arg)) + (remove-if (lambda (m) (equal (car m) arg)) ocaml-visible-modules)) )) (message "%S" (mapcar 'car (ocaml-visible-modules)))) @@ -284,8 +282,7 @@ If defined Module and Entry are represented by a region in the buffer, and are nil otherwise. For debugging purposes, it returns the string Module.entry if called -with an optional non-nil argument. -" +with an optional non-nil argument." (save-excursion (let ((module) (entry)) (if (looking-at "[ \n]") (skip-chars-backward " ")) @@ -322,12 +319,12 @@ with an optional non-nil argument. (if (null pattern) (apply 'append (mapcar 'ocaml-module-symbols list)) (let ((pat (concat "^" (regexp-quote pattern))) (res)) - (iter - '(lambda (l) - (iter '(lambda (x) - (if (string-match pat (car l)) - (if (member x res) nil (setq res (cons x res))))) - (ocaml-module-symbols l))) + (mapc + (lambda (l) + (mapc (lambda (x) + (if (string-match pat (car l)) + (if (member x res) nil (setq res (cons x res))))) + (ocaml-module-symbols l))) list) res) ))) @@ -427,8 +424,7 @@ where identifier is defined." (defvar ocaml-info-prefix "ocaml-lib" "Prefix of ocaml info files describing library modules. Suffix .info will be added to info files. -Additional suffix .gz may be added if info files are compressed. -") +Additional suffix .gz may be added if info files are compressed.") ;; (defun ocaml-hevea-info-add-entries (entries dir name) @@ -474,15 +470,14 @@ Additional suffix .gz may be added if info files are compressed. of \\[Info-default-directory-list] and the base name \\[ocaml-info-name] of files to look for. -This uses info files produced by HeVeA. -" +This uses info files produced by HeVeA." (let ((collect) (seen)) - (iter '(lambda (d) - (if (member d seen) nil - (setq collect - (ocaml-hevea-info-add-entries - collect d ocaml-info-prefix)) - (setq done (cons d seen)))) + (mapc (lambda (d) + (if (member d seen) nil + (setq collect + (ocaml-hevea-info-add-entries + collect d ocaml-info-prefix)) + (setq seen (cons d seen)))) Info-directory-list) collect)) @@ -520,12 +515,12 @@ of files to look for. This uses info files produced by ocamldoc." (require 'info) (let ((collect) (seen)) - (iter '(lambda (d) - (if (member d seen) nil - (setq collect - (ocaml-ocamldoc-info-add-entries collect d - ocaml-info-prefix)) - (setq done (cons d seen)))) + (mapc (lambda (d) + (if (member d seen) nil + (setq collect + (ocaml-ocamldoc-info-add-entries collect d + ocaml-info-prefix)) + (setq seen (cons d seen)))) Info-directory-list) collect)) @@ -536,11 +531,11 @@ This uses info files produced by ocamldoc." nil means do not use info. - A function to build the list lazily (at the first call). The result of + A function to build the list lazily (at the first call). The result of the function call will be assign permanently to this variable for future -uses. We provide two default functions \\[ocaml-info-default-function] -(info produced by HeVeA is the default) and \\[ocaml-info-default-function] -(info produced by ocamldoc). +uses. We provide two default functions `ocaml-hevea-info' +\(info produced by HeVeA is the default) and `ocaml-ocamldoc-info' +\(info produced by ocamldoc). Otherwise, this value should be an alist binding module names to info entries of the form to \"(entry)section\" be taken by the \\[info] @@ -548,7 +543,7 @@ command. An entry may be an info module or a complete file name." ) (defun ocaml-info-alist () - "Call by need value of variable ocaml-info-alist" + "Call by need value of variable `ocaml-info-alist'." (cond ((listp ocaml-info-alist)) ((functionp ocaml-info-alist) @@ -574,9 +569,11 @@ command. An entry may be an info module or a complete file name." ;; Help function. +(defvar view-return-to-alist) +(defvar view-exit-action) (defun ocaml-goto-help (&optional module entry same-window) - "Searches info manual for MODULE and ENTRY in MODULE. + "Search info manual for MODULE and ENTRY in MODULE. If unspecified, MODULE and ENTRY are inferred from the position in the current buffer using \\[ocaml-qualified-identifier]." (interactive) @@ -635,6 +632,15 @@ current buffer using \\[ocaml-qualified-identifier]." (if (window-live-p window) (select-window window)) )) +(defface ocaml-help-face + '((t :background "#88FF44")) + "Face to highlight expressions and types.") + +(defvar ocaml-help-ovl + (let ((ovl (make-overlay 1 1))) + (overlay-put ovl 'face 'ocaml-help-face) + ovl)) + (defun caml-help (arg) "Find documentation for OCaml qualified identifiers. @@ -642,11 +648,11 @@ It attemps to recognize an qualified identifier of the form ``Module . entry'' around point using function `ocaml-qualified-identifier'. If Module is undetermined it is temptatively guessed from the identifier name -and according to visible modules. If this is still unsucessful, the user is +and according to visible modules. If this is still unsucessful, the user is then prompted for a Module name. The documentation for Module is first seach in the info manual if available, -then in the ``module.mli'' source file. The entry is then searched in the +then in the ``module.mli'' source file. The entry is then searched in the documentation. Visible modules are computed only once, at the first call. @@ -657,8 +663,7 @@ Prefix arg 0 forces recompilation of visible modules (and their content) from the file content. Prefix arg 4 prompts for Module and identifier instead of guessing values -from the possition of point in the current buffer. -" +from the possition of point in the current buffer." (interactive "p") (delete-overlay ocaml-help-ovl) (let ((module) (entry) (module-entry)) @@ -743,16 +748,10 @@ buffer positions." (setq ocaml-links (cons section all)) ))))) -(defvar ocaml-link-map (make-sparse-keymap)) -(define-key ocaml-link-map [mouse-2] 'ocaml-link-goto) - -(defvar ocaml-help-ovl (make-overlay 1 1)) -(make-face 'ocaml-help-face) -(set-face-doc-string 'ocaml-help-face - "face for hilighting expressions and types") -(if (not (face-differs-from-default-p 'ocaml-help-face)) - (set-face-background 'ocaml-help-face "#88FF44")) -(overlay-put ocaml-help-ovl 'face 'ocaml-help-face) +(defvar ocaml-link-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-2] 'ocaml-link-goto) + map)) (defun ocaml-help-show (arg) (let ((right (point)) @@ -763,6 +762,7 @@ buffer positions." )) (defun ocaml-link-goto (click) + "Follow link at point." (interactive "e") (let* ((pos (caml-event-point-start click)) (win (caml-event-window click)) @@ -787,12 +787,10 @@ buffer positions." (if (window-live-p window) (select-window window)) ))) -(cond - ((and (x-display-color-p) - (not (memq 'ocaml-link-face (face-list)))) - (make-face 'ocaml-link-face) - (set-face-foreground 'ocaml-link-face "Purple"))) +(defface ocaml-link-face + '((((class color)) :foreground "Purple")) + "Face to highlight hyperlinks.") (defun ocaml-link-activate (section) (let ((links (ocaml-info-links section))) @@ -853,3 +851,4 @@ buffer positions." (provide 'caml-help) +;;; caml-help.el ends here diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el index c8314a64..13735594 100644 --- a/emacs/caml-hilit.el +++ b/emacs/caml-hilit.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-hilit.el 12149 2012-02-10 16:15:24Z doligez $ *) - ; Highlighting patterns for hilit19 under caml-mode ; defined also in caml.el diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 727ae641..47060a2c 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el 12800 2012-07-30 18:59:07Z doligez $ *) - ; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. ;; XEmacs compatibility @@ -56,6 +54,8 @@ The current list of keywords is: type call ident" ) +(defvar caml-types-position-re nil) + (let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"") (caml-types-number-re "\\([0-9]*\\)")) (setq caml-types-position-re @@ -331,7 +331,8 @@ See `caml-types-location-re' for annotation file format. caml-types-annotation-date (not (caml-types-date< caml-types-annotation-date type-date))) (if (and type-date target-date (caml-types-date< type-date target-date)) - (error (format "`%s' is more recent than `%s'" target-path type-path))) + (error (format "`%s' is more recent than `%s'" + target-path type-path))) (message "Reading annotation file...") (let* ((type-buf (caml-types-find-file type-path)) (tree (with-current-buffer type-buf diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el index f9eac11e..f74c883c 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-xemacs.el 11156 2011-07-27 14:17:02Z doligez $ *) - (require 'overlay) ;; for caml-help.el diff --git a/emacs/caml.el b/emacs/caml.el index 90a142d9..6ad464ae 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml.el 12973 2012-09-28 16:54:20Z doligez $ *) - ;;; caml.el --- OCaml code editing commands for Emacs ;; Xavier Leroy, july 1993. @@ -407,26 +405,27 @@ have caml-electric-indent on, which see.") "Syntax table in use in Caml mode buffers.") (if caml-mode-syntax-table () - (setq caml-mode-syntax-table (make-syntax-table)) - ; backslash is an escape sequence - (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table) - ; ( is first character of comment start - (modify-syntax-entry ?\( "()1n" caml-mode-syntax-table) - ; * is second character of comment start, - ; and first character of comment end - (modify-syntax-entry ?* ". 23n" caml-mode-syntax-table) - ; ) is last character of comment end - (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table) - ; backquote was a string-like delimiter (for character literals) - ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table) - ; quote and underscore are part of words - (modify-syntax-entry ?' "w" caml-mode-syntax-table) - (modify-syntax-entry ?_ "w" caml-mode-syntax-table) - ; ISO-latin accented letters and EUC kanjis are part of words - (let ((i 160)) - (while (< i 256) - (modify-syntax-entry i "w" caml-mode-syntax-table) - (setq i (1+ i))))) + (let ((n (if (string-match "XEmacs" (emacs-version)) "" "n"))) + (setq caml-mode-syntax-table (make-syntax-table)) + ; backslash is an escape sequence + (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table) + ; ( is first character of comment start + (modify-syntax-entry ?\( (concat "()1" n) caml-mode-syntax-table) + ; * is second character of comment start, + ; and first character of comment end + (modify-syntax-entry ?* (concat ". 23" n) caml-mode-syntax-table) + ; ) is last character of comment end + (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table) + ; backquote was a string-like delimiter (for character literals) + ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table) + ; quote and underscore are part of words + (modify-syntax-entry ?' "w" caml-mode-syntax-table) + (modify-syntax-entry ?_ "w" caml-mode-syntax-table) + ; ISO-latin accented letters and EUC kanjis are part of words + (let ((i 160)) + (while (< i 256) + (modify-syntax-entry i "w" caml-mode-syntax-table) + (setq i (1+ i)))))) (defvar caml-mode-abbrev-table nil "Abbrev table used for Caml mode buffers.") @@ -543,36 +542,41 @@ have caml-electric-indent on, which see.") (caml-show-imenu))) (run-hooks 'caml-mode-hook)) -(defun caml-set-compile-command () - "Hook to set compile-command locally, unless there is a Makefile or - a _build directory or a _tags file in the current directory." - (interactive) - (unless (or (null buffer-file-name) - (file-exists-p "makefile") - (file-exists-p "Makefile") - (file-exists-p "_build") - (file-exists-p "_tags")) - (let* ((filename (file-name-nondirectory buffer-file-name)) - (basename (file-name-sans-extension filename)) - (command nil)) - (cond - ((string-match ".*\\.mli\$" filename) - (setq command "ocamlc -c")) - ((string-match ".*\\.ml\$" filename) - (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) - ) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamllex")) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamlyacc")) - ) - (if command - (progn - (make-local-variable 'compile-command) - (setq compile-command (concat command " " filename)))) - ))) -(add-hook 'caml-mode-hook 'caml-set-compile-command) +;; Disabled because it assumes make and does not play well with ocamlbuild. +;; See PR#4469 for details. + +;; (defun caml-set-compile-command () +;; "Hook to set compile-command locally, unless there is a Makefile or +;; a _build directory or a _tags file in the current directory." +;; (interactive) +;; (unless (or (null buffer-file-name) +;; (file-exists-p "makefile") +;; (file-exists-p "Makefile") +;; (file-exists-p "_build") +;; (file-exists-p "_tags")) +;; (let* ((filename (file-name-nondirectory buffer-file-name)) +;; (basename (file-name-sans-extension filename)) +;; (command nil)) +;; (cond +;; ((string-match ".*\\.mli\$" filename) +;; (setq command "ocamlc -c")) +;; ((string-match ".*\\.ml\$" filename) +;; (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) +;; ) +;; ((string-match ".*\\.mll\$" filename) +;; (setq command "ocamllex")) +;; ((string-match ".*\\.mll\$" filename) +;; (setq command "ocamlyacc")) +;; ) +;; (if command +;; (progn +;; (make-local-variable 'compile-command) +;; (setq compile-command (concat command " " filename)))) +;; ))) + +;; (add-hook 'caml-mode-hook 'caml-set-compile-command) + ;;; Auxiliary function. Garrigue 96-11-01. @@ -693,14 +697,14 @@ the current point." ((looking-at "[ \t]*method") (setq method-alist (cons index method-alist))))) ;; build menu - (mapcar - '(lambda (pair) - (if (symbol-value (cdr pair)) - (setq menu-alist - (cons - (cons (car pair) - (sort (symbol-value (cdr pair)) 'imenu--sort-by-name)) - menu-alist)))) + (mapc + (lambda (pair) + (if (symbol-value (cdr pair)) + (setq menu-alist + (cons + (cons (car pair) + (sort (symbol-value (cdr pair)) 'imenu--sort-by-name)) + menu-alist)))) '(("Values" . value-alist) ("Types" . type-alist) ("Modules" . module-alist) @@ -789,17 +793,32 @@ variable caml-mode-indentation." ;; In Emacs 19, the regexps in compilation-error-regexp-alist do not ;; match the error messages when the language is not English. ;; Hence we add a regexp. +;; FIXME do we (still) have i18n of error messages ??? (defconst caml-error-regexp "^[ A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]" "Regular expression matching the error messages produced by camlc.") +;; Newer emacs versions support line/char ranges +;; We will adapt OCaml to output error messages in a compatible format. +;; In the meantime we add the new format here in addition to the old one. +(defconst caml-error-regexp-newstyle + (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\)," + "char \\([0-9]+\\) to line \\([0-9]+\\), char \\([0-9]+\\):") + "Regular expression matching the error messages produced by ocamlc/ocamlopt.") + (if (boundp 'compilation-error-regexp-alist) - (or (assoc caml-error-regexp - compilation-error-regexp-alist) - (setq compilation-error-regexp-alist - (cons (list caml-error-regexp 1 2) - compilation-error-regexp-alist)))) + (progn + (or (assoc caml-error-regexp + compilation-error-regexp-alist) + (setq compilation-error-regexp-alist + (cons (list caml-error-regexp 1 2) + compilation-error-regexp-alist))) + (or (assoc caml-error-regexp-newstyle + compilation-error-regexp-alist) + (setq compilation-error-regexp-alist + (cons (list caml-error-regexp-newstyle 1 '(2 . 4) '(3 . 5)) + compilation-error-regexp-alist))))) ;; A regexp to extract the range info diff --git a/emacs/camldebug.el b/emacs/camldebug.el index a805c389..6e83bacc 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: camldebug.el 12800 2012-07-30 18:59:07Z doligez $ *) - ;;; Run camldebug under Emacs ;;; Derived from gdb.el. ;;; gdb.el is Copyright (C) 1988 Free Software Foundation, Inc, and is part @@ -98,8 +96,8 @@ The following commands are available: \\[camldebug-display-frame] displays in the other window the last line referred to in the camldebug buffer. -\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug window, -call camldebug to step, backstep or next and then update the other window +\\[camldebug-step], \\[camldebug-back] and \\[camldebug-next], in the camldebug +window,call camldebug to step, backstep or next and then update the other window with the current file and position. If you are in a source file, you may select a point to break @@ -252,7 +250,8 @@ representation is simply concatenated with the COMMAND." camldebug-goto-position "-[0-9]+[ \t]*\\(before\\).*\n") camldebug-filter-accumulator) - (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+-" + (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)" + "[ \t]+[0-9]+-" camldebug-goto-position "[ \t]*\\(after\\).*\n") camldebug-filter-accumulator))) @@ -712,7 +711,8 @@ Obeying it means displaying in another window the specified file and line." ;;; Miscellaneous. (defun camldebug-module-name (filename) - (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1))) + (substring filename (string-match "\\([^/]*\\)\\.ml$" filename) + (match-end 1))) ;;; The camldebug-call function must do the right thing whether its ;;; invoking keystroke is from the camldebug buffer itself (via diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index 1b343d00..8a775772 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -10,8 +10,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: inf-caml.el 12149 2012-02-10 16:15:24Z doligez $ *) - ;;; inf-caml.el --- run the OCaml toplevel in an Emacs buffer ;; Xavier Leroy, july 1993. @@ -282,7 +280,8 @@ should lies." (column (- (match-end 3) (match-beginning 3))) (width (- (match-end 2) (match-end 3)))) (if (string-match "^\\(.*\\)[<]EOF[>]$" expr) - (setq expr (substring expr (match-beginning 1) (match-end 1)))) + (setq expr (substring expr (match-beginning 1) + (match-end 1)))) (switch-to-buffer buf) (re-search-backward (concat "^" (regexp-quote expr) "$") diff --git a/emacs/ocamltags.in b/emacs/ocamltags.in index 4c6c7d89..7b1f41cf 100644 --- a/emacs/ocamltags.in +++ b/emacs/ocamltags.in @@ -12,8 +12,6 @@ ;(* *) ;(***********************************************************************) -;(* $Id: ocamltags.in 12800 2012-07-30 18:59:07Z doligez $ *) - ;; Copyright (C) 1998 Ian Zimmerman ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -24,7 +22,6 @@ ;; 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. -;; $Id: ocamltags.in 12800 2012-07-30 18:59:07Z doligez $ (require 'caml) diff --git a/lex/.depend b/lex/.depend index b0df0b87..455421e7 100644 --- a/lex/.depend +++ b/lex/.depend @@ -22,10 +22,10 @@ main.cmo : syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi \ lexer.cmi cset.cmi compact.cmi common.cmi main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \ lexer.cmx cset.cmx compact.cmx common.cmx -output.cmo : syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi -output.cmx : syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi -outputbis.cmo : syntax.cmi lexgen.cmi common.cmi outputbis.cmi -outputbis.cmx : syntax.cmx lexgen.cmx common.cmx outputbis.cmi +output.cmo : lexgen.cmi compact.cmi common.cmi output.cmi +output.cmx : lexgen.cmx compact.cmx common.cmx output.cmi +outputbis.cmo : lexgen.cmi common.cmi outputbis.cmi +outputbis.cmx : lexgen.cmx common.cmx outputbis.cmi parser.cmo : syntax.cmi cset.cmi parser.cmi parser.cmx : syntax.cmx cset.cmx parser.cmi syntax.cmo : cset.cmi syntax.cmi diff --git a/lex/Makefile b/lex/Makefile index 545955d4..debad6e6 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -10,25 +10,24 @@ # # ######################################################################### -# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $ - # The lexer generator CAMLC=../boot/ocamlrun ../boot/ocamlc -strict-sequence -nostdlib -I ../boot CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib -COMPFLAGS=-warn-error A +COMPFLAGS=-w +33..39 -warn-error A CAMLYACC=../boot/ocamlyacc YACCFLAGS=-v CAMLLEX=../boot/ocamlrun ../boot/ocamllex CAMLDEP=../boot/ocamlrun ../tools/ocamldep -OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo +OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \ + compact.cmo common.cmo output.cmo outputbis.cmo main.cmo all: ocamllex allopt: ocamllex.opt ocamllex: $(OBJS) - $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS) + $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS) ocamllex.opt: $(OBJS:.cmo=.cmx) $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx) diff --git a/lex/Makefile.nt b/lex/Makefile.nt index 4ac7865a..38c71f2e 100644 --- a/lex/Makefile.nt +++ b/lex/Makefile.nt @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $ - # The lexer generator include ../config/Makefile @@ -26,13 +24,14 @@ CAMLLEX=../boot/ocamlrun ../boot/ocamllex CAMLDEP=../boot/ocamlrun ../tools/ocamldep DEPFLAGS= -OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo compact.cmo common.cmo output.cmo outputbis.cmo main.cmo +OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \ + compact.cmo common.cmo output.cmo outputbis.cmo main.cmo all: ocamllex syntax.cmo allopt: ocamllex.opt ocamllex: $(OBJS) - $(CAMLC) $(LINKFLAGS) -o ocamllex $(OBJS) + $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS) ocamllex.opt: $(OBJS:.cmo=.cmx) $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx) diff --git a/lex/common.ml b/lex/common.ml index 5638185d..36f8225e 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -58,7 +58,7 @@ let copy_chars_unix ic oc start stop = done let copy_chars_win32 ic oc start stop = - for i = start to stop - 1 do + for _i = start to stop - 1 do let c = input_char ic in if c <> '\r' then output_char oc c done @@ -68,14 +68,14 @@ let copy_chars = "Win32" | "Cygwin" -> copy_chars_win32 | _ -> copy_chars_unix -let copy_chunk sourcefile ic oc trl loc add_parens = +let copy_chunk ic oc trl loc add_parens = if loc.start_pos < loc.end_pos || add_parens then begin - fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile; + fprintf oc "# %d \"%s\"\n" loc.start_line loc.loc_file; if add_parens then begin - for i = 1 to loc.start_col - 1 do output_char oc ' ' done; + for _i = 1 to loc.start_col - 1 do output_char oc ' ' done; output_char oc '('; end else begin - for i = 1 to loc.start_col do output_char oc ' ' done; + for _i = 1 to loc.start_col do output_char oc ' ' done; end; seek_in ic loc.start_pos; copy_chars ic oc loc.start_pos loc.end_pos; @@ -122,7 +122,7 @@ let output_tag_access oc = function | Sum (a,i) -> fprintf oc "(%a + %d)" output_base_mem a i -let output_env sourcefile ic oc tr env = +let output_env ic oc tr env = let pref = ref "let" in match env with | [] -> () @@ -138,7 +138,7 @@ let output_env sourcefile ic oc tr env = List.iter (fun ((x,pos),v) -> fprintf oc "%s\n" !pref ; - copy_chunk sourcefile ic oc tr pos false ; + copy_chunk ic oc tr pos false ; begin match v with | Ident_string (o,nstart,nend) -> fprintf oc diff --git a/lex/common.mli b/lex/common.mli index f85baa01..c71febe8 100644 --- a/lex/common.mli +++ b/lex/common.mli @@ -14,13 +14,12 @@ type line_tracker;; val open_tracker : string -> out_channel -> line_tracker val close_tracker : line_tracker -> unit val copy_chunk : - string -> in_channel -> out_channel -> line_tracker -> Syntax.location -> bool -> unit val output_mem_access : out_channel -> int -> unit val output_memory_actions : string -> out_channel -> Lexgen.memory_action list -> unit val output_env : - string -> in_channel -> out_channel -> line_tracker -> + in_channel -> out_channel -> line_tracker -> (Lexgen.ident * Lexgen.ident_info) list -> unit val output_args : out_channel -> string list -> unit diff --git a/lex/compact.ml b/lex/compact.ml index 9a811bd8..1f620ab8 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: compact.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Compaction of an automata *) open Lexgen diff --git a/lex/compact.mli b/lex/compact.mli index 4d3245ab..90f2ed99 100644 --- a/lex/compact.mli +++ b/lex/compact.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: compact.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Compaction of an automata *) type lex_tables = { tbl_base: int array; (* Perform / Shift *) diff --git a/lex/cset.ml b/lex/cset.ml index 650c68d4..8c3d176f 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -11,9 +11,6 @@ (* *) (***********************************************************************) -(* $Id: cset.ml 11156 2011-07-27 14:17:02Z doligez $ *) - - exception Bad type t = (int * int) list diff --git a/lex/cset.mli b/lex/cset.mli index 733187a3..daad6e59 100644 --- a/lex/cset.mli +++ b/lex/cset.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: cset.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Set of characters encoded as list of intervals *) type t diff --git a/lex/lexer.mli b/lex/lexer.mli index a33c50a8..ca8e4c49 100644 --- a/lex/lexer.mli +++ b/lex/lexer.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: lexer.mli 11156 2011-07-27 14:17:02Z doligez $ *) - val main: Lexing.lexbuf -> Parser.token exception Lexical_error of string * string * int * int diff --git a/lex/lexer.mll b/lex/lexer.mll index e82fe70e..8fc472e6 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: lexer.mll 12418 2012-05-02 14:41:30Z doligez $ *) - (* The lexical analyzer for lexer definitions. Bootstrapped! *) { @@ -168,12 +166,13 @@ rule main = parse } | '{' { let p = Lexing.lexeme_end_p lexbuf in + let f = p.Lexing.pos_fname in let n1 = p.Lexing.pos_cnum and l1 = p.Lexing.pos_lnum and s1 = p.Lexing.pos_bol in brace_depth := 1; let n2 = handle_lexical_error action lexbuf in - Taction({start_pos = n1; end_pos = n2; + Taction({loc_file = f; start_pos = n1; end_pos = n2; start_line = l1; start_col = n1 - s1}) } | '=' { Tequal } | '|' { Tor } diff --git a/lex/lexgen.ml b/lex/lexgen.ml index f47cfd49..035e3fe6 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -12,8 +12,6 @@ (* *) (***********************************************************************) -(* $Id: lexgen.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Compiling a lexer definition *) open Syntax @@ -80,7 +78,8 @@ type ('args,'action) automata_entry = (* A lot of sets and map structures *) -module Ints = Set.Make(struct type t = int let compare = compare end) +module Ints = + Set.Make(struct type t = int let compare (x:t) y = compare x y end) let id_compare (id1,_) (id2,_) = String.compare id1 id2 @@ -508,7 +507,7 @@ let encode_lexdef def = chars_count := 0; let entry_list = List.map - (fun {name=entry_name ; args=args ; shortest=shortest ; clauses= casedef} -> + (fun {name=entry_name; args=args; shortest=shortest; clauses=casedef} -> let (re,actions,_,ntags) = encode_casedef casedef in { lex_name = entry_name; lex_regexp = re; @@ -524,8 +523,8 @@ let encode_lexdef def = Extension to tagged automata. Confer Ville Larikari - ``NFAs with Tagged Transitions, their Conversion to Deterministic - Automata and Application to Regular Expressions''. + 'NFAs with Tagged Transitions, their Conversion to Deterministic + Automata and Application to Regular Expressions'. Symposium on String Processing and Information Retrieval (SPIRE 2000), http://kouli.iki.fi/~vlaurika/spire2000-tnfa.ps (See also) @@ -606,7 +605,8 @@ let followpos size entry_list = fill s r2 | Star r -> fill (TransSet.union (firstpos r) s) r in - List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) entry_list ; + List.iter (fun (entry,_,_) -> fill TransSet.empty entry.lex_regexp) + entry_list; v (************************) @@ -620,7 +620,8 @@ module StateSet = module MemMap = - Map.Make (struct type t = int let compare = Pervasives.compare end) + Map.Make (struct type t = int + let compare (x:t) y = Pervasives.compare x y end) type 'a dfa_state = {final : int * ('a * int TagMap.t) ; diff --git a/lex/lexgen.mli b/lex/lexgen.mli index 5fbd58c4..3fc8c905 100644 --- a/lex/lexgen.mli +++ b/lex/lexgen.mli @@ -10,9 +10,6 @@ (* *) (***********************************************************************) -(* $Id: lexgen.mli 11156 2011-07-27 14:17:02Z doligez $ *) - - (* raised when there are too many bindings (>= 254 memory cells) *) exception Memory_overflow diff --git a/lex/main.ml b/lex/main.ml index 3616ab45..97b114a1 100644 --- a/lex/main.ml +++ b/lex/main.ml @@ -10,12 +10,9 @@ (* *) (***********************************************************************) -(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* The lexer generator. Command-line parsing. *) open Syntax -open Lexgen let ml_automata = ref false let source_name = ref None @@ -35,7 +32,8 @@ let print_version_num () = let specs = ["-ml", Arg.Set ml_automata, - " Output code that does not use the Lexing module built-in automata interpreter"; + " Output code that does not use the Lexing module built-in automata \ + interpreter"; "-o", Arg.String (fun x -> output_name := Some x), " Set output file name to "; "-q", Arg.Set Common.quiet_mode, " Do not display informational messages"; diff --git a/lex/output.ml b/lex/output.ml index 7e4982ba..d99f2f90 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -10,12 +10,9 @@ (* *) (***********************************************************************) -(* $Id: output.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Output the DFA tables and its entry points *) open Printf -open Syntax open Lexgen open Compact open Common @@ -95,12 +92,12 @@ let output_entry sourcefile ic oc oci e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env sourcefile ic oc oci env; - copy_chunk sourcefile ic oc oci loc true; + output_env ic oc oci env; + copy_chunk ic oc oci loc true; fprintf oc "\n") e.auto_actions; fprintf oc " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; \ - __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n" + __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state\n\n" e.auto_name output_args e.auto_args (* Main output function *) @@ -126,7 +123,7 @@ let output_lexdef sourcefile ic oc oci header tables entry_points trailer = Printf.printf "%d additional bytes used for bindings\n" size_groups ; flush stdout; if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - copy_chunk sourcefile ic oc oci header false; + copy_chunk ic oc oci header false; output_tables oc tables; begin match entry_points with [] -> () @@ -137,4 +134,4 @@ let output_lexdef sourcefile ic oc oci header tables entry_points trailer = entries; output_string oc ";;\n\n"; end; - copy_chunk sourcefile ic oc oci trailer false + copy_chunk ic oc oci trailer false diff --git a/lex/output.mli b/lex/output.mli index 050d9a0c..96d8a4d6 100644 --- a/lex/output.mli +++ b/lex/output.mli @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: output.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* Output the DFA tables and its entry points *) val output_lexdef: diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 89e7492b..7e8cba6e 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -10,12 +10,9 @@ (* *) (***********************************************************************) -(* $Id: outputbis.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (* Output the DFA tables and its entry points *) open Printf -open Syntax open Lexgen open Common @@ -160,7 +157,7 @@ let output_entry sourcefile ic oc tr e = \n let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\ \n lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\ \n lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\ -\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\ +\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos+lexbuf.Lexing.lex_curr_pos};\ \n match __ocaml_lex_result with\n" e.auto_name output_args e.auto_args e.auto_mem_size (output_memory_actions " ") init_moves init_num ; @@ -168,8 +165,8 @@ let output_entry sourcefile ic oc tr e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env sourcefile ic oc tr env ; - copy_chunk sourcefile ic oc tr loc true; + output_env ic oc tr env ; + copy_chunk ic oc tr loc true; fprintf oc "\n") e.auto_actions; fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n\n\n" @@ -179,7 +176,7 @@ let output_entry sourcefile ic oc tr e = let output_lexdef sourcefile ic oc tr header entry_points transitions trailer = - copy_chunk sourcefile ic oc tr header false; + copy_chunk ic oc tr header false; output_automata oc transitions ; begin match entry_points with [] -> () @@ -190,4 +187,4 @@ let output_lexdef sourcefile ic oc tr header entry_points transitions trailer = entries; output_string oc ";;\n\n"; end; - copy_chunk sourcefile ic oc tr trailer false + copy_chunk ic oc tr trailer false diff --git a/lex/outputbis.mli b/lex/outputbis.mli index b4d6931f..6c045122 100644 --- a/lex/outputbis.mli +++ b/lex/outputbis.mli @@ -10,7 +10,6 @@ (* *) (***********************************************************************) -(* $Id: outputbis.mli 11156 2011-07-27 14:17:02Z doligez $ *) val output_lexdef : string -> in_channel -> diff --git a/lex/parser.mly b/lex/parser.mly index 3d976cd9..b42cced9 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -10,8 +10,6 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly 11156 2011-07-27 14:17:02Z doligez $ */ - /* The grammar for lexer definitions */ %{ @@ -50,7 +48,8 @@ let as_cset = function %token Tchar %token Tstring %token Taction -%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket +%token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof + Tlbracket Trbracket %token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Tsharp %right Tas @@ -75,7 +74,8 @@ header: Taction { $1 } | /*epsilon*/ - { { start_pos = 0; end_pos = 0; start_line = 1; start_col = 0 } } + { { loc_file = ""; start_pos = 0; end_pos = 0; start_line = 1; + start_col = 0 } } ; named_regexps: named_regexps Tlet Tident Tequal regexp @@ -163,6 +163,7 @@ regexp: {let p1 = Parsing.rhs_start_pos 3 and p2 = Parsing.rhs_end_pos 3 in let p = { + loc_file = p1.Lexing.pos_fname ; start_pos = p1.Lexing.pos_cnum ; end_pos = p2.Lexing.pos_cnum ; start_line = p1.Lexing.pos_lnum ; diff --git a/lex/syntax.ml b/lex/syntax.ml index 20a09fab..72f101e2 100644 --- a/lex/syntax.ml +++ b/lex/syntax.ml @@ -10,18 +10,18 @@ (* *) (***********************************************************************) -(* $Id: syntax.ml 11156 2011-07-27 14:17:02Z doligez $ *) - -(* This apparently useless implmentation file is in fact required +(* This apparently useless implementation file is in fact required by the pa_ocamllex syntax extension *) (* The shallow abstract syntax *) -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } +type location = { + loc_file : string; + start_pos : int; + end_pos : int; + start_line : int; + start_col : int; +} type regular_expression = Epsilon diff --git a/lex/syntax.mli b/lex/syntax.mli index 028e48a5..55c3c117 100644 --- a/lex/syntax.mli +++ b/lex/syntax.mli @@ -10,15 +10,15 @@ (* *) (***********************************************************************) -(* $Id: syntax.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (* The shallow abstract syntax *) -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } +type location = { + loc_file : string; + start_pos : int; + end_pos : int; + start_line : int; + start_col : int; +} type regular_expression = Epsilon diff --git a/man/Makefile b/man/Makefile index 7b0c2b0d..916ea24a 100644 --- a/man/Makefile +++ b/man/Makefile @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile 12246 2012-03-16 15:53:07Z doligez $ - include ../config/Makefile DIR=$(MANDIR)/man$(MANEXT) diff --git a/man/ocaml.m b/man/ocaml.m index 311598e1..39baf7b7 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocaml.m 12086 2012-01-27 12:50:31Z doligez $ -.\" .TH OCAML 1 .SH NAME @@ -66,6 +64,9 @@ exits after the execution of the last phrase. The following command-line options are recognized by .BR ocaml (1). .TP +.B \-absname +Show absolute filenames in error messages. +.TP .BI \-I \ directory Add the given directory to the list of directories searched for source and compiled files. By default, the current directory is @@ -102,6 +103,12 @@ in the user's home directory. Labels are not ignored in types, labels may be used in applications, and labelled parameters can be given in any order. This is the default. .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -126,6 +133,12 @@ window. Do not include the standard library directory in the list of directories searched for source and compiled files. .TP +.BI \-ppx \ command +After parsing, pipe the abstract syntax tree through the preprocessor +.IR command . +The format of the input and ouput of the preprocessor +are not yet documented. +.TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. When using labelled arguments @@ -144,6 +157,18 @@ Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP +.B \-stdin +Read the standard input as a script file rather than starting an +interactive session. +.TP +.B \-strict\-sequence +Force the left-hand part of each sequence to have type unit. +.TP .B \-unsafe Turn bound checking off on array and string accesses (the .BR v.(i) and s.[i] @@ -168,9 +193,9 @@ for the syntax of the argument. .TP .BI \-warn-error \ warning-list -Treat as errors the warnings described by the argument +Mark as fatal the warnings described by the argument .IR warning\-list . -Note that a warning is not triggered (and not treated as error) if +Note that a warning is not triggered (and does not trigger an error) if it is disabled by the .B \-w option. See @@ -179,6 +204,14 @@ for the syntax of the .I warning\-list argument. .TP +.B \-warn\-help +Show the description of all available warning numbers. +.TP +.BI \- \ file +Use +.I file +as a script file name, even when it starts with a hyphen (-). +.TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. diff --git a/man/ocamlc.m b/man/ocamlc.m index 6f9a39b0..fb3902a8 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlc.m 12800 2012-07-30 18:59:07Z doligez $ -.\" .TH OCAMLC 1 .SH NAME @@ -195,6 +193,9 @@ command line, unless the .B -noautolink option is given. .TP +.B \-absname +Show absolute filenames in error messages. +.TP .B \-annot Dump detailed information about the compilation (types, bindings, tail-calls, etc). The information for file @@ -208,10 +209,19 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP -.B \-dtypes -Has been deprecated. Please use -.B \-annot -instead. +.B \-bin\-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc) in binary format. The information for file +.IR src .ml +is put into file +.IR src .cmt. +In case of a type error, dump +all the information inferred by the type-checker before the error. +The annotation files produced by +.B \-bin\-annot +contain more information +and are much more compact than the files produced by +.BR \-annot . .TP .B \-c Compile only. Suppress the linking phase of the @@ -233,8 +243,10 @@ option to the C linker when linking in "custom runtime" mode (see the .B \-custom option). This causes the given C library to be linked with the program. .TP -.B \-ccopt -Pass the given option to the C compiler and linker, when linking in +.BI \-ccopt \ option +Pass the given +.I option +to the C compiler and linker, when linking in "custom runtime" mode (see the .B \-custom option). For instance, @@ -243,6 +255,11 @@ causes the C linker to search for C libraries in directory .IR dir . .TP +.B \-compat\-32 +Check that the generated bytecode executable can run on 32-bit +platforms and signal an error if it cannot. This is useful when +compiling bytecode on a 64-bit machine. +.TP .B \-config Print the version number of .BR ocamlc (1) @@ -292,6 +309,11 @@ executable file, where .BR ocamlrun (1) can find it and use it. .TP +.BI \-for\-pack \ ident +This option is accepted for compatibility with +.BR ocamlopt (1) +; it does nothing. +.TP .B \-g Add debugging information while compiling and linking. This option is required in order to be able to debug the program with @@ -369,6 +391,12 @@ bytecode executables produced with the option .B ocamlc\ \-use\-runtime .IR runtime-name . .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -389,6 +417,12 @@ and pass the correct C libraries and options on the command line. Ignore non-optional labels in types. Labels cannot be used in applications, and parameter order becomes strict. .TP +.B \-nostdlib +Do not include the standard library directory in the list of +directories searched for compiled interfaces (see option +.B \-I +). +.TP .BI \-o \ exec\-file Specify the name of the output file produced by the linker. The default output name is @@ -441,6 +475,12 @@ file is built from the basename of the source file with the extension .ppi for an interface (.mli) file and .ppo for an implementation (.ml) file. .TP +.BI \-ppx \ command +After parsing, pipe the abstract syntax tree through the preprocessor +.IR command . +The format of the input and ouput of the preprocessor +are not yet documented. +.TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. When using labelled arguments @@ -470,8 +510,13 @@ then the .B d suffix is supported and gives a debug version of the runtime. .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP .B \-strict\-sequence -The left-hand part of a sequence must have type unit. +Force the left-hand part of each sequence to have type unit. .TP .B \-thread Compile or link multithreaded programs, in combination with the @@ -505,30 +550,29 @@ invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP -.BR \-vnum \ or\ \-version -Print the version number of the compiler in short form (e.g. "3.11.0"), -then exit. -.TP .B \-vmthread Compile or link multithreaded programs, in combination with the VM-level threads library described in .IR The\ OCaml\ user's\ manual . .TP +.BR \-vnum \ or\ \-version +Print the version number of the compiler in short form (e.g. "3.11.0"), +then exit. +.TP .BI \-w \ warning\-list -Enable, disable, or mark as errors the warnings specified by the argument +Enable, disable, or mark as fatal the warnings specified by the argument .IR warning\-list . Each warning can be .IR enabled \ or\ disabled , and each warning can be -.I marked -(as error) or -.IR unmarked . +.IR fatal or +.IR non-fatal . If a warning is disabled, it isn't displayed and doesn't affect -compilation in any way (even if it is marked). If a warning is enabled, +compilation in any way (even if it is fatal). If a warning is enabled, it is displayed normally by the compiler whenever the source code -triggers it. If it is enabled and marked, the compiler will stop with -an error after displaying the warnings if the source code triggers it. +triggers it. If it is enabled and fatal, the compiler will also stop +with an error after displaying it. The .I warning\-list @@ -544,7 +588,7 @@ between them. A warning specifier is one of the following: .IR num . .BI @ num -\ \ Enable and mark warning number +\ \ Enable and mark as fatal warning number .IR num . .BI + num1 .. num2 @@ -562,7 +606,7 @@ and (inclusive). .BI @ num1 .. num2 -\ \ Enable and mark all warnings between +\ \ Enable and mark as fatal all warnings between .I num1 and .I num2 @@ -579,7 +623,7 @@ The letter may be uppercase or lowercase. The letter may be uppercase or lowercase. .BI @ letter -\ \ Enable and mark the set of warnings corresponding to +\ \ Enable and mark as fatal the set of warnings corresponding to .IR letter . The letter may be uppercase or lowercase. @@ -600,7 +644,7 @@ The warning numbers are as follows. \ \ \ Suspicious-looking end-of-comment mark. 3 -\ \ \ Deprecated syntax. +\ \ \ Deprecated feature. 4 \ \ \ Fragile pattern matching: matching that will remain @@ -694,6 +738,55 @@ pattern. \ \ A non-escaped end-of-line was found in a string constant. This may cause portability problems between Unix and Windows. +30 +\ \ Two labels or constructors of the same name are defined in two +mutually recursive types. + +31 +\ \ A module is linked twice in the same executable. + +32 +\ \ Unused value declaration. + +33 +\ \ Unused open statement. + +34 +\ \ Unused type declaration. + +35 +\ \ Unused for-loop index. + +36 +\ \ Unused ancestor variable. + +37 +\ \ Unused constructor. + +38 +\ \ Unused exception constructor. + +39 +\ \ Unused rec flag. + +40 +\ \ Constructor or label name used out of scope. + +41 +\ \ Ambiguous constructor or label name. + +42 +\ \ Disambiguated constructor or label name. + +43 +\ \ Nonoptional label applied as optional. + +44 +\ \ Open statement shadows an already defined identifier. + +45 +\ \ Open statement shadows an already defined label or constructor. + The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. @@ -713,7 +806,7 @@ mentioned here corresponds to the empty set. \ 5 .B K -\ 32, 33, 34, 35, 36, 37 +\ 32, 33, 34, 35, 36, 37, 38, 39 .B L \ 6 @@ -747,7 +840,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 . +.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. @@ -763,11 +856,11 @@ the .B \-w option: a .B + -sign (or an uppercase letter) turns the corresponding warnings into errors, a +sign (or an uppercase letter) marks the corresponding warnings as fatal, a .B \- -sign (or a lowercase letter) turns them back into warnings, and a +sign (or a lowercase letter) turns them back into non-fatal warnings, and a .B @ -sign both enables and marks the corresponding warnings. +sign both enables and marks as fatal the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error @@ -776,8 +869,10 @@ compiling your program with later versions of OCaml when they add new warnings. The default setting is -.B \-warn\-error\ -a -(none of the warnings is treated as an error). +.B \-warn\-error\ -a (all warnings are non-fatal). +.TP +.B \-warn\-help +Show the description of all available warning numbers. .TP .B \-where Print the location of the standard library, then exit. diff --git a/man/ocamlcp.m b/man/ocamlcp.m index cb7a6b3c..7967f25d 100644 --- a/man/ocamlcp.m +++ b/man/ocamlcp.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlcp.m 12429 2012-05-03 17:23:51Z doligez $ -.\" .TH "OCAMLCP" 1 .SH NAME diff --git a/man/ocamldebug.m b/man/ocamldebug.m index f740ff8e..a470150a 100644 --- a/man/ocamldebug.m +++ b/man/ocamldebug.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamldebug.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLDEBUG 1 .SH NAME diff --git a/man/ocamldep.m b/man/ocamldep.m index 558cae55..ba7ddb8c 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamldep.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLDEP 1 .SH NAME @@ -56,6 +54,9 @@ and with the native-code compiler The following command-line options are recognized by .BR ocamldep (1). .TP +.B \-absname +Show absolute filenames in error messages. +.TP .BI \-I \ directory Add the given directory to the list of directories searched for source files. If a source file foo.ml mentions an external @@ -113,6 +114,10 @@ to call the given .I command as a preprocessor for each source file. .TP +.BI \-ppx \ command +Pipe abstract syntax tree through preprocessor +.IR command . +.TP .B \-slash Under Unix, this option does nothing. .TP diff --git a/man/ocamldoc.m b/man/ocamldoc.m index 2cb71761..73ca3a65 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamldoc.m 12800 2012-07-30 18:59:07Z doligez $ -.\" .TH OCAMLDOC 1 \" .de Sh \" Subsection heading @@ -239,6 +237,10 @@ options. Pipe sources through preprocessor .IR command . .TP +.BI \-ppx \ command +Pipe abstract syntax tree through preprocessor +.IR command . +.TP .B \-sort Sort the list of top-level modules before generating the documentation. .TP diff --git a/man/ocamllex.m b/man/ocamllex.m index 25724cc0..d59755ba 100644 --- a/man/ocamllex.m +++ b/man/ocamllex.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamllex.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLLEX 1 .SH NAME diff --git a/man/ocamlmktop.m b/man/ocamlmktop.m index 0fbb372f..fd6aaa82 100644 --- a/man/ocamlmktop.m +++ b/man/ocamlmktop.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlmktop.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLMKTOP 1 .SH NAME @@ -64,7 +62,7 @@ The following command-line options are recognized by .B \-v Print the version string of the compiler and exit. .TP -.BR \-vnum or \-version +.BR \-vnum \ or\ \-version Print the version number of the compiler in short form and exit. .TP .BI \-cclib\ \-l libname diff --git a/man/ocamlopt.m b/man/ocamlopt.m index eaf0cde1..998651bb 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlopt.m 12800 2012-07-30 18:59:07Z doligez $ -.\" .TH OCAMLOPT 1 .SH NAME @@ -157,6 +155,9 @@ command line, unless the .B \-noautolink option is given. .TP +.B \-absname +Show absolute filenames in error messages. +.TP .B \-annot Dump detailed information about the compilation (types, bindings, tail-calls, etc). The information for file @@ -170,10 +171,19 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP -.B \-dtypes -Has been deprecated. Please use -.BI \-annot -instead. +.B \-bin\-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc) in binary format. The information for file +.IR src .ml +is put into file +.IR src .cmt. +In case of a type error, dump +all the information inferred by the type-checker before the error. +The annotation files produced by +.B \-bin\-annot +contain more information +and are much more compact than the files produced by +.BR \-annot . .TP .B \-c Compile only. Suppress the linking phase of the @@ -253,6 +263,11 @@ adds the subdirectory .B labltk of the standard library to the search path. .TP +.BI \-impl \ filename +Compile the file +.I filename +as an implementation file, even if its extension is not .ml. +.TP .BI \-inline \ n Set aggressiveness of inlining to .IR n , @@ -296,6 +311,12 @@ flag forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -407,6 +428,12 @@ is redirected to an intermediate file, which is compiled. If there are no compilation errors, the intermediate file is deleted afterwards. .TP +.BI \-ppx \ command +After parsing, pipe the abstract syntax tree through the preprocessor +.IR command . +The format of the input and ouput of the preprocessor +are not yet documented. +.TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. All programs accepted in @@ -455,6 +482,11 @@ flag. Some constraints might also apply to the way the extra native objects have been compiled (under Linux AMD 64, they must contain only position-independent code). .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP .B \-strict\-sequence The left-hand part of a sequence must have type unit. .TP @@ -492,7 +524,7 @@ Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. .TP .BI \-w \ warning\-list -Enable, disable, or mark as errors the warnings specified by the argument +Enable, disable, or mark as fatal the warnings specified by the argument .IR warning\-list . See .BR ocamlc (1) @@ -500,7 +532,7 @@ for the syntax of .IR warning-list . .TP .BI \-warn\-error \ warning\-list -Mark as errors the warnings specified in the argument +Mark as fatal the warnings specified in the argument .IR warning\-list . The compiler will stop with an error when one of these warnings is emitted. The @@ -510,11 +542,11 @@ the .B \-w option: a .B + -sign (or an uppercase letter) turns the corresponding warnings into errors, a +sign (or an uppercase letter) marks the corresponding warnings as fatal, a .B \- -sign (or a lowercase letter) turns them back into warnings, and a +sign (or a lowercase letter) turns them back into non-fatal warnings, and a .B @ -sign both enables and marks the corresponding warnings. +sign both enables and marks as fatal the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error @@ -523,8 +555,11 @@ compiling your program with later versions of OCaml when they add new warnings. The default setting is -.B \-warn\-error\ -a -(none of the warnings is treated as an error). +.B \-warn\-error\ -a (all warnings are non-fatal). +.TP +.B \-warn\-help +Show the description of all available warning numbers. +.TP .TP .B \-where Print the location of the standard library, then exit. diff --git a/man/ocamlprof.m b/man/ocamlprof.m index 4d802d1d..a3bac2c6 100644 --- a/man/ocamlprof.m +++ b/man/ocamlprof.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlprof.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLPROF 1 .SH NAME diff --git a/man/ocamlrun.m b/man/ocamlrun.m index f54a2e00..ea467ea4 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlrun.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLRUN 1 .SH NAME @@ -114,8 +112,8 @@ This variable must be a sequence of parameter specifications. A parameter specification is an option letter followed by an = sign, a decimal number (or a hexadecimal number prefixed by .BR 0x ), -and an optional multiplier. There are nine options, six of which -correspond to the fields of the +and an optional multiplier. The options are documented below; the +last six correspond to the fields of the .B control record documented in .IR "The OCaml user's manual", @@ -133,10 +131,19 @@ parsers. When this option is on, the pushdown automaton that executes the parsers prints a trace of its actions. This option takes no argument. .TP +.BR R +Turn on randomization of all hash tables by default (see the +.B Hashtbl +module of the standard library). This option takes no +argument. +.TP +.BR h +The initial size of the major heap (in words). +.TP .BR a \ (allocation_policy) The policy used for allocating in the OCaml heap. Possible values are 0 for the next-fit policy, and 1 for the first-fit -policy. Next-fit is somewhat faster, but first-fit is better for +policy. Next-fit is usually faster, but first-fit is better for avoiding fragmentation and the associated heap compactions. .TP .BR s \ (minor_heap_size) @@ -154,9 +161,6 @@ The heap compaction trigger setting. .BR l \ (stack_limit) The limit (in words) of the stack size. .TP -.BR h -The initial size of the major heap (in words). -.TP .BR v \ (verbose) What GC messages to print to stderr. This is a sum of values selected from the following: @@ -191,7 +195,7 @@ shared libraries). The multiplier is .BR k , -.BR M \ or +.BR M ,\ or .BR G , for multiplication by 2^10, 2^20, and 2^30 respectively. For example, on a 32-bit machine under bash, the command diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m index 4fc9bade..133994e2 100644 --- a/man/ocamlyacc.m +++ b/man/ocamlyacc.m @@ -10,8 +10,6 @@ .\"* * .\"*********************************************************************** .\" -.\" $Id: ocamlyacc.m 11156 2011-07-27 14:17:02Z doligez $ -.\" .TH OCAMLYACC 1 .SH NAME diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c6872427..c1d0865c 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -10,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: myocamlbuild.ml 12032 2012-01-17 21:47:36Z lefessan $ *) - open Ocamlbuild_plugin open Command open Arch @@ -22,7 +20,7 @@ module C = Myocamlbuild_config let windows = Sys.os_type = "Win32";; if windows then tag_any ["windows"];; let ccomptype = C.ccomptype -let () = if ccomptype <> "cc" then eprintf "ccomptype: %s@." ccomptype;; +(*let () = if ccomptype <> "cc" then eprintf "ccomptype: %s@." ccomptype;;*) let fp_cat oc f = with_input_file ~bin:true f (fun ic -> copy_chan ic oc) @@ -251,7 +249,6 @@ let setup_arch arch = let camlp4_arch = dir "" [ - dir "stdlib" []; dir "camlp4" [ dir "build" []; dir_pack "Camlp4" [ @@ -268,8 +265,7 @@ setup_arch camlp4_arch;; Pathname.define_context "" ["stdlib"];; Pathname.define_context "utils" [Pathname.current_dir_name; "stdlib"];; -Pathname.define_context "camlp4" ["camlp4"; "stdlib"];; -Pathname.define_context "camlp4/boot" ["camlp4"; "stdlib"];; +Pathname.define_context "camlp4/boot" ["camlp4"];; Pathname.define_context "camlp4/Camlp4Parsers" ["camlp4"; "stdlib"];; Pathname.define_context "camlp4/Camlp4Printers" ["camlp4"; "stdlib"];; Pathname.define_context "camlp4/Camlp4Filters" ["camlp4"; "stdlib"];; @@ -285,7 +281,7 @@ Pathname.define_context "debugger" ["bytecomp"; "utils"; "typing"; "parsing"; "t Pathname.define_context "otherlibs/dynlink" ["otherlibs/dynlink"; "bytecomp"; "utils"; "typing"; "parsing"; "stdlib"];; Pathname.define_context "otherlibs/dynlink/nat" ["otherlibs/dynlink/nat"; "asmcomp"; "stdlib"];; Pathname.define_context "asmcomp" ["asmcomp"; "bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];; -Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];; +Pathname.define_context "ocamlbuild" ["ocamlbuild"; "."];; Pathname.define_context "lex" ["lex"; "stdlib"];; List.iter (fun x -> let x = "otherlibs"/x in Pathname.define_context x [x; "stdlib"]) diff --git a/ocamlbuild/.depend b/ocamlbuild/.depend new file mode 100644 index 00000000..5344160e --- /dev/null +++ b/ocamlbuild/.depend @@ -0,0 +1,192 @@ +bool.cmi : +command.cmi : tags.cmi signatures.cmi +configuration.cmi : tags.cmi pathname.cmi +digest_cache.cmi : +discard_printf.cmi : +display.cmi : tags.cmi +exit_codes.cmi : +fda.cmi : slurp.cmi +findlib.cmi : signatures.cmi command.cmi +flags.cmi : tags.cmi command.cmi +glob.cmi : signatures.cmi glob_ast.cmi bool.cmi +glob_ast.cmi : bool.cmi +glob_lexer.cmi : glob_ast.cmi +hooks.cmi : +hygiene.cmi : slurp.cmi +lexers.cmi : glob.cmi +log.cmi : tags.cmi signatures.cmi +main.cmi : +my_std.cmi : signatures.cmi +my_unix.cmi : +ocaml_arch.cmi : signatures.cmi command.cmi +ocaml_compiler.cmi : tags.cmi rule.cmi pathname.cmi command.cmi +ocaml_dependencies.cmi : pathname.cmi +ocaml_specific.cmi : +ocaml_tools.cmi : tags.cmi rule.cmi pathname.cmi command.cmi +ocaml_utils.cmi : tags.cmi pathname.cmi command.cmi +ocamlbuild.cmi : +ocamlbuild_executor.cmi : +ocamlbuild_plugin.cmi : +ocamlbuild_unix_plugin.cmi : +ocamlbuild_where.cmi : +ocamlbuildlight.cmi : +options.cmi : slurp.cmi signatures.cmi command.cmi +param_tags.cmi : tags.cmi +pathname.cmi : signatures.cmi +plugin.cmi : +ppcache.cmi : +report.cmi : solver.cmi +resource.cmi : slurp.cmi pathname.cmi my_std.cmi command.cmi +rule.cmi : tags.cmi resource.cmi pathname.cmi my_std.cmi command.cmi +shell.cmi : +signatures.cmi : +slurp.cmi : my_unix.cmi +solver.cmi : pathname.cmi +tags.cmi : signatures.cmi +tools.cmi : tags.cmi pathname.cmi +bool.cmo : bool.cmi +bool.cmx : bool.cmi +command.cmo : tags.cmi shell.cmi param_tags.cmi my_unix.cmi my_std.cmi \ + log.cmi lexers.cmi command.cmi +command.cmx : tags.cmx shell.cmx param_tags.cmx my_unix.cmx my_std.cmx \ + log.cmx lexers.cmi command.cmi +configuration.cmo : tags.cmi param_tags.cmi my_std.cmi log.cmi lexers.cmi \ + glob.cmi configuration.cmi +configuration.cmx : tags.cmx param_tags.cmx my_std.cmx log.cmx lexers.cmi \ + glob.cmx configuration.cmi +digest_cache.cmo : shell.cmi pathname.cmi options.cmi my_unix.cmi my_std.cmi \ + digest_cache.cmi +digest_cache.cmx : shell.cmx pathname.cmx options.cmx my_unix.cmx my_std.cmx \ + digest_cache.cmi +discard_printf.cmo : discard_printf.cmi +discard_printf.cmx : discard_printf.cmi +display.cmo : tags.cmi my_unix.cmi my_std.cmi discard_printf.cmi display.cmi +display.cmx : tags.cmx my_unix.cmx my_std.cmx discard_printf.cmx display.cmi +exit_codes.cmo : exit_codes.cmi +exit_codes.cmx : exit_codes.cmi +fda.cmo : pathname.cmi options.cmi log.cmi hygiene.cmi fda.cmi +fda.cmx : pathname.cmx options.cmx log.cmx hygiene.cmx fda.cmi +findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi command.cmi findlib.cmi +findlib.cmx : my_unix.cmx my_std.cmx lexers.cmi command.cmx findlib.cmi +flags.cmo : tags.cmi param_tags.cmi command.cmi bool.cmi flags.cmi +flags.cmx : tags.cmx param_tags.cmx command.cmx bool.cmx flags.cmi +glob.cmo : my_std.cmi glob_lexer.cmi glob_ast.cmi bool.cmi glob.cmi +glob.cmx : my_std.cmx glob_lexer.cmi glob_ast.cmx bool.cmx glob.cmi +glob_ast.cmo : bool.cmi glob_ast.cmi +glob_ast.cmx : bool.cmx glob_ast.cmi +hooks.cmo : hooks.cmi +hooks.cmx : hooks.cmi +hygiene.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_std.cmi \ + log.cmi hygiene.cmi +hygiene.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_std.cmx \ + log.cmx hygiene.cmi +log.cmo : my_unix.cmi my_std.cmi display.cmi log.cmi +log.cmx : my_unix.cmx my_std.cmx display.cmx log.cmi +main.cmo : tools.cmi tags.cmi solver.cmi slurp.cmi shell.cmi rule.cmi \ + resource.cmi report.cmi plugin.cmi pathname.cmi param_tags.cmi \ + options.cmi ocaml_utils.cmi ocaml_specific.cmi ocaml_dependencies.cmi \ + my_unix.cmi my_std.cmi log.cmi lexers.cmi hooks.cmi flags.cmi fda.cmi \ + exit_codes.cmi digest_cache.cmi configuration.cmi command.cmi main.cmi +main.cmx : tools.cmx tags.cmx solver.cmx slurp.cmx shell.cmx rule.cmx \ + resource.cmx report.cmx plugin.cmx pathname.cmx param_tags.cmx \ + options.cmx ocaml_utils.cmx ocaml_specific.cmx ocaml_dependencies.cmx \ + my_unix.cmx my_std.cmx log.cmx lexers.cmi hooks.cmx flags.cmx fda.cmx \ + exit_codes.cmx digest_cache.cmx configuration.cmx command.cmx main.cmi +my_std.cmo : my_std.cmi +my_std.cmx : my_std.cmi +my_unix.cmo : my_std.cmi my_unix.cmi +my_unix.cmx : my_std.cmx my_unix.cmi +ocaml_arch.cmo : pathname.cmi my_std.cmi command.cmi ocaml_arch.cmi +ocaml_arch.cmx : pathname.cmx my_std.cmx command.cmx ocaml_arch.cmi +ocaml_compiler.cmo : tools.cmi tags.cmi rule.cmi resource.cmi pathname.cmi \ + options.cmi ocaml_utils.cmi ocaml_dependencies.cmi ocaml_arch.cmi \ + my_std.cmi log.cmi command.cmi ocaml_compiler.cmi +ocaml_compiler.cmx : tools.cmx tags.cmx rule.cmx resource.cmx pathname.cmx \ + options.cmx ocaml_utils.cmx ocaml_dependencies.cmx ocaml_arch.cmx \ + my_std.cmx log.cmx command.cmx ocaml_compiler.cmi +ocaml_dependencies.cmo : tools.cmi resource.cmi pathname.cmi ocaml_utils.cmi \ + my_std.cmi log.cmi ocaml_dependencies.cmi +ocaml_dependencies.cmx : tools.cmx resource.cmx pathname.cmx ocaml_utils.cmx \ + my_std.cmx log.cmx ocaml_dependencies.cmi +ocaml_specific.cmo : tools.cmi tags.cmi rule.cmi pathname.cmi options.cmi \ + ocaml_utils.cmi ocaml_tools.cmi ocaml_compiler.cmi my_std.cmi log.cmi \ + flags.cmi findlib.cmi configuration.cmi command.cmi ocaml_specific.cmi +ocaml_specific.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \ + ocaml_utils.cmx ocaml_tools.cmx ocaml_compiler.cmx my_std.cmx log.cmx \ + flags.cmx findlib.cmx configuration.cmx command.cmx ocaml_specific.cmi +ocaml_tools.cmo : tools.cmi tags.cmi rule.cmi pathname.cmi options.cmi \ + ocaml_utils.cmi ocaml_compiler.cmi my_std.cmi flags.cmi command.cmi \ + ocaml_tools.cmi +ocaml_tools.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \ + ocaml_utils.cmx ocaml_compiler.cmx my_std.cmx flags.cmx command.cmx \ + ocaml_tools.cmi +ocaml_utils.cmo : tools.cmi tags.cmi pathname.cmi param_tags.cmi options.cmi \ + my_std.cmi log.cmi lexers.cmi flags.cmi command.cmi ocaml_utils.cmi +ocaml_utils.cmx : tools.cmx tags.cmx pathname.cmx param_tags.cmx options.cmx \ + my_std.cmx log.cmx lexers.cmi flags.cmx command.cmx ocaml_utils.cmi +ocamlbuild.cmo : ocamlbuild_unix_plugin.cmi ocamlbuild.cmi +ocamlbuild.cmx : ocamlbuild_unix_plugin.cmx ocamlbuild.cmi +ocamlbuild_Myocamlbuild_config.cmo : +ocamlbuild_Myocamlbuild_config.cmx : +ocamlbuild_executor.cmo : ocamlbuild_executor.cmi +ocamlbuild_executor.cmx : ocamlbuild_executor.cmi +ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi +ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi +ocamlbuild_unix_plugin.cmo : ocamlbuild_executor.cmi my_unix.cmi my_std.cmi \ + exit_codes.cmi ocamlbuild_unix_plugin.cmi +ocamlbuild_unix_plugin.cmx : ocamlbuild_executor.cmx my_unix.cmx my_std.cmx \ + exit_codes.cmx ocamlbuild_unix_plugin.cmi +ocamlbuild_where.cmo : ocamlbuild_Myocamlbuild_config.cmo \ + ocamlbuild_where.cmi +ocamlbuild_where.cmx : ocamlbuild_Myocamlbuild_config.cmx \ + ocamlbuild_where.cmi +ocamlbuildlight.cmo : ocamlbuildlight.cmi +ocamlbuildlight.cmx : ocamlbuildlight.cmi +options.cmo : shell.cmi ocamlbuild_where.cmi \ + ocamlbuild_Myocamlbuild_config.cmo my_std.cmi log.cmi lexers.cmi \ + command.cmi options.cmi +options.cmx : shell.cmx ocamlbuild_where.cmx \ + ocamlbuild_Myocamlbuild_config.cmx my_std.cmx log.cmx lexers.cmi \ + command.cmx options.cmi +param_tags.cmo : my_std.cmi log.cmi lexers.cmi param_tags.cmi +param_tags.cmx : my_std.cmx log.cmx lexers.cmi param_tags.cmi +pathname.cmo : shell.cmi options.cmi my_unix.cmi my_std.cmi log.cmi glob.cmi \ + pathname.cmi +pathname.cmx : shell.cmx options.cmx my_unix.cmx my_std.cmx log.cmx glob.cmx \ + pathname.cmi +plugin.cmo : tools.cmi tags.cmi shell.cmi rule.cmi pathname.cmi options.cmi \ + ocamlbuild_where.cmi my_unix.cmi my_std.cmi log.cmi command.cmi \ + plugin.cmi +plugin.cmx : tools.cmx tags.cmx shell.cmx rule.cmx pathname.cmx options.cmx \ + ocamlbuild_where.cmx my_unix.cmx my_std.cmx log.cmx command.cmx \ + plugin.cmi +ppcache.cmo : shell.cmi pathname.cmi my_std.cmi log.cmi command.cmi \ + ppcache.cmi +ppcache.cmx : shell.cmx pathname.cmx my_std.cmx log.cmx command.cmx \ + ppcache.cmi +report.cmo : solver.cmi resource.cmi my_std.cmi log.cmi glob.cmi report.cmi +report.cmx : solver.cmx resource.cmx my_std.cmx log.cmx glob.cmx report.cmi +resource.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_unix.cmi \ + my_std.cmi log.cmi lexers.cmi glob_ast.cmi glob.cmi digest_cache.cmi \ + command.cmi resource.cmi +resource.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_unix.cmx \ + my_std.cmx log.cmx lexers.cmi glob_ast.cmx glob.cmx digest_cache.cmx \ + command.cmx resource.cmi +rule.cmo : tags.cmi shell.cmi resource.cmi pathname.cmi options.cmi \ + my_std.cmi log.cmi digest_cache.cmi command.cmi rule.cmi +rule.cmx : tags.cmx shell.cmx resource.cmx pathname.cmx options.cmx \ + my_std.cmx log.cmx digest_cache.cmx command.cmx rule.cmi +shell.cmo : tags.cmi my_unix.cmi my_std.cmi log.cmi shell.cmi +shell.cmx : tags.cmx my_unix.cmx my_std.cmx log.cmx shell.cmi +slurp.cmo : my_unix.cmi my_std.cmi slurp.cmi +slurp.cmx : my_unix.cmx my_std.cmx slurp.cmi +solver.cmo : rule.cmi resource.cmi pathname.cmi my_std.cmi log.cmi \ + command.cmi solver.cmi +solver.cmx : rule.cmx resource.cmx pathname.cmx my_std.cmx log.cmx \ + command.cmx solver.cmi +tags.cmo : tags.cmi +tags.cmx : tags.cmi +tools.cmo : tags.cmi rule.cmi pathname.cmi my_std.cmi log.cmi \ + configuration.cmi tools.cmi +tools.cmx : tags.cmx rule.cmx pathname.cmx my_std.cmx log.cmx \ + configuration.cmx tools.cmi diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index eec086a5..fe011bd6 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -10,8 +10,6 @@ # # ######################################################################### -# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $ - .PHONY: all byte native profile debug ppcache doc ifndef INSTALL_PREFIX diff --git a/ocamlbuild/Makefile.noboot b/ocamlbuild/Makefile.noboot new file mode 100644 index 00000000..02f7c735 --- /dev/null +++ b/ocamlbuild/Makefile.noboot @@ -0,0 +1,226 @@ +#(***********************************************************************) +#(* *) +#(* ocamlbuild *) +#(* *) +#(* Wojciech Meyer *) +#(* *) +#(* Copyright 2012 Institut National de Recherche en Informatique et *) +#(* en Automatique. All rights reserved. This file is distributed *) +#(* under the terms of the Q Public License version 1.0. *) +#(* *) +#(***********************************************************************) + +# This file removes the dependency on ocamlbuild itself, thus removes need +# for bootstrap. The base for this Makefile was ocamldoc Makefile. + +include ../config/Makefile + +# Various commands and dir +########################## +CAMLRUN = ../boot/ocamlrun +OCAMLC = ../ocamlcomp.sh +OCAMLOPT = ../ocamlcompopt.sh +OCAMLDEP = $(CAMLRUN) ../tools/ocamldep +OCAMLLEX = $(CAMLRUN) ../boot/ocamllex +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) + +# For installation +############## +MKDIR=mkdir -p +CP=cp -f +OCAMLBUILD=ocamlbuild +OCAMLBUILD_OPT=$(OCAMLBUILD).opt +OCAMLBUILD_LIBCMA=ocamlbuildlib.cma +OCAMLBUILD_LIBCMI=ocamlbuildlib.cmi +OCAMLBUILD_LIBCMXA=ocamlbuild.cmxa +OCAMLBUILD_LIBA=ocamlbuild.$(A) +INSTALL_LIBDIR=$(OCAMLLIB)/ocamlbuild +INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom +INSTALL_BINDIR=$(OCAMLBIN) +INSTALL_MANODIR=$(MANDIR)/man3 + +INSTALL_MLIS= +INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) + +# Compilation +############# +OCAMLSRCDIR=.. +INCLUDES_DEP= + +INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ + -I $(OCAMLSRCDIR)/otherlibs/str \ + -I $(OCAMLSRCDIR)/otherlibs/dynlink \ + -I $(OCAMLSRCDIR)/otherlibs/unix + +INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) + +COMPFLAGS=$(INCLUDES) -warn-error A +LINKFLAGS=$(INCLUDES) + +CMOFILES_PACK= \ + ocamlbuild_Myocamlbuild_config.cmo \ + discard_printf.cmo \ + my_std.cmo \ + bool.cmo \ + glob_ast.cmo \ + glob_lexer.cmo \ + glob.cmo \ + lexers.cmo \ + my_unix.cmo \ + tags.cmo \ + display.cmo \ + log.cmo \ + param_tags.cmo \ + shell.cmo \ + slurp.cmo \ + ocamlbuild_where.cmo \ + command.cmo \ + options.cmo \ + pathname.cmo \ + digest_cache.cmo \ + resource.cmo \ + rule.cmo \ + flags.cmo \ + solver.cmo \ + report.cmo \ + ocaml_arch.cmo \ + hygiene.cmo \ + configuration.cmo \ + tools.cmo \ + fda.cmo \ + plugin.cmo \ + ocaml_utils.cmo \ + ocaml_dependencies.cmo \ + ocaml_compiler.cmo \ + ocaml_tools.cmo \ + hooks.cmo \ + findlib.cmo \ + ocaml_specific.cmo \ + exit_codes.cmo \ + main.cmo + +BASE_CMOFILES= ocamlbuild_executor.cmo \ + ocamlbuild_unix_plugin.cmo + +INSTALL_LIBFILES = $(BASE_CMOFILES) \ + $(BASE_CMOFILES:.cmo=.cmi) \ + $(OCAMLBUILD_LIBCMA) \ + $(OCAMLBUILD).cmo \ + $(OCAMLBUILD)_pack.cmi + +INSTALL_BINFILES = $(OCAMLBUILD) + +CMXFILES= $(CMOFILES:.cmo=.cmx) + +CMXFILES_PACK= $(CMOFILES_PACK:.cmo=.cmx) +CMIFILES_PACK= $(CMOFILES_PACK:.cmo=.cmi) signatures.cmi + +EXECMOFILES_PACK= $(CMOFILES_PACK) +EXECMXFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmx) +EXECMIFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmi) + +LIBCMOFILES_PACK= $(CMOFILES_PACK) +LIBCMXFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmx) +LIBCMIFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmi) + +# Les cmo et cmx de la distrib OCAML +OCAMLCMOFILES= +OCAMLCMXFILES=$(OCAMLCMOFILES_PACK:.cmo=.cmx) + +all: exe lib +opt: $(OCAMLBUILD).native +exe: $(OCAMLBUILD) +lib: $(OCAMLBUILD_LIBCMA) + +opt.opt: exeopt libopt +exeopt: $(OCAMLBUILD_OPT) +libopt: $(OCAMLBUILD_LIBCMXA) $(OCAMLBUILD_LIBCMI) + +debug: + $(MAKE) OCAMLPP="" + +$(OCAMLBUILD)_pack.cmo: $(CMOFILES_PACK) $(CMIFILES_PACK) + $(OCAMLC) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMOFILES_PACK) signatures.mli + +$(OCAMLBUILD)_pack.cmx: $(EXECMXFILES_PACK) + $(OCAMLOPT) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMXFILES_PACK) + +$(OCAMLBUILD): $(OCAMLBUILD)_pack.cmo $(CMOFILES) $(OCAMLBUILD).cmo $(BASE_CMOFILES) + $(OCAMLC) -o $@ unix.cma $(LINKFLAGS) $(OCAMLBUILD)_pack.cmo $(CMOFILES) + +$(OCAMLBUILD).native: $(OCAMLBUILD)_pack.cmx $(CMXFILES) + $(OCAMLOPT) -o $@ $(LINKFLAGS) $(CMXFILES) + +$(OCAMLBUILD_LIBCMA): $(LIBCMOFILES_PACK) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES_PACK) +$(OCAMLBUILD_LIBCMXA): $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) + +# generic rules : +################# + +.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs + +.ml.cmo: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.mli.cmi: + $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< + +.ml.cmxs: + $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $< + +.mll.ml: + $(OCAMLLEX) $< + +.mly.ml: + $(OCAMLYACC) -v $< + +.mly.mli: + $(OCAMLYACC) -v $< + +# Installation targets +###################### +install: dummy + if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi + $(CP) $(OCAMLBUILD) $(INSTALL_BINDIR)/$(OCAMLBUILD)$(EXE) + $(CP) $(INSTALL_LIBFILES) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_BINFILES) $(INSTALL_BINDIR) + +installopt: + if test -f $(OCAMLBUILD_OPT) ; then $(MAKE) installopt_really ; fi + +installopt_really: + if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi + $(CP) ocamlbuild.hva $(OCAMLBUILD_LIBA) $(OCAMLBUILD_LIBCMXA) $(INSTALL_LIBDIR) + $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) + + +# backup, clean and depend : +############################ + +clean:: dummy + @rm -f *~ \#*\# + @rm -f $(OCAMLBUILD) $(OCAMLBUILD_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) + @rm -f glob_lexer.ml lexers.ml + +depend:: + $(OCAMLDEP) $(INCLUDES_DEP) *.mli *.mll *.mly *.ml > .depend + +dummy: + +include .depend + +# Additional rules +glob_lexer.cmo: glob_lexer.cmi +lexers.cmo: lexers.cmi + +glob_lexer.cmx: glob_lexer.cmi +lexers.cmx: lexers.cmi diff --git a/ocamlbuild/bool.ml b/ocamlbuild/bool.ml index d31944c1..56dec3b0 100644 --- a/ocamlbuild/bool.ml +++ b/ocamlbuild/bool.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/bool.mli b/ocamlbuild/bool.mli index 59ead55a..8ebbd440 100644 --- a/ocamlbuild/bool.mli +++ b/ocamlbuild/bool.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index 1ce80c97..64b818c1 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -100,7 +101,7 @@ let env_path = lazy begin let paths = try parse_path (Lexing.from_string path_var) - with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg)) + with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos)) in let norm_current_dir_name path = if path = "" then Filename.current_dir_name else path diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index f54b8e8a..18547a45 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index 7a4f2f4f..c77cca92 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -31,17 +32,17 @@ let (configs, add_config) = configs := config :: !configs; Hashtbl.clear cache) -let parse_string s = - let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in +let parse_lexbuf ?dir source lexbuf = + lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source }; + let conf = Lexers.conf_lines dir lexbuf in add_config conf +let parse_string s = parse_lexbuf (Printf.sprintf "String %S" s) (Lexing.from_string s) + let parse_file ?dir file = - try - with_input_file file begin fun ic -> - let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in - add_config conf - end - with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg)) + with_input_file file begin fun ic -> + parse_lexbuf ?dir (Printf.sprintf "File %S" file) (Lexing.from_channel ic) + end let key_match = Glob.eval @@ -61,7 +62,8 @@ let tags_of_filename s = let () = Hashtbl.replace cache s res in res -let has_tag tag = Tags.mem tag (tags_of_filename "") +let global_tags () = tags_of_filename "" +let has_tag tag = Tags.mem tag (global_tags ()) let tag_file file tags = if tags <> [] then parse_string (Printf.sprintf "%S: %s" file (String.concat ", " tags));; diff --git a/ocamlbuild/configuration.mli b/ocamlbuild/configuration.mli index 745dcc26..37ee64eb 100644 --- a/ocamlbuild/configuration.mli +++ b/ocamlbuild/configuration.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -33,3 +34,6 @@ val tag_file : Pathname.t -> Tags.elt list -> unit (** [tag_any tag_list] Tag anything with all given tags. *) val tag_any : Tags.elt list -> unit + +(** the tags that apply to any file *) +val global_tags : unit -> Tags.t diff --git a/ocamlbuild/digest_cache.ml b/ocamlbuild/digest_cache.ml index 5f624afc..319e7d06 100644 --- a/ocamlbuild/digest_cache.ml +++ b/ocamlbuild/digest_cache.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/digest_cache.mli b/ocamlbuild/digest_cache.mli index 7fb389eb..d10627a2 100644 --- a/ocamlbuild/digest_cache.mli +++ b/ocamlbuild/digest_cache.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/discard_printf.ml b/ocamlbuild/discard_printf.ml index b48b43c2..8adc83e8 100644 --- a/ocamlbuild/discard_printf.ml +++ b/ocamlbuild/discard_printf.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/discard_printf.mli b/ocamlbuild/discard_printf.mli index 255f5d1a..a3d2a012 100644 --- a/ocamlbuild/discard_printf.mli +++ b/ocamlbuild/discard_printf.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 11586662..725d351b 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -362,7 +363,11 @@ let event di ?(pretend=false) command target tags = match di.di_display_line with | Classic -> if pretend then - (if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command) + begin + (* This should work, even on Windows *) + let command = Filename.basename command in + if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command + end else (if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command) | Sophisticated ds -> diff --git a/ocamlbuild/display.mli b/ocamlbuild/display.mli index fd0b066d..4dc399b1 100644 --- a/ocamlbuild/display.mli +++ b/ocamlbuild/display.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/examples/example1/hello.ml b/ocamlbuild/examples/example1/hello.ml index c85cb66b..f21b6ae1 100644 --- a/ocamlbuild/examples/example1/hello.ml +++ b/ocamlbuild/examples/example1/hello.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + let _ = Printf.printf "Hello, %s ! My name is %s\n" (if Array.length Sys.argv > 1 then Sys.argv.(1) else "stranger") diff --git a/ocamlbuild/examples/example2/greet.ml b/ocamlbuild/examples/example2/greet.ml index ec808891..84f1e28f 100644 --- a/ocamlbuild/examples/example2/greet.ml +++ b/ocamlbuild/examples/example2/greet.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + type how = Nicely | Badly;; let greet how who = diff --git a/ocamlbuild/examples/example2/hello.ml b/ocamlbuild/examples/example2/hello.ml index b48806a3..4dee0a70 100644 --- a/ocamlbuild/examples/example2/hello.ml +++ b/ocamlbuild/examples/example2/hello.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + open Greet let _ = diff --git a/ocamlbuild/examples/example3/epoch.ml b/ocamlbuild/examples/example3/epoch.ml index ad95a039..0d235d16 100644 --- a/ocamlbuild/examples/example3/epoch.ml +++ b/ocamlbuild/examples/example3/epoch.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + let _ = let s = Num.num_of_string (Printf.sprintf "%.0f" (Unix.gettimeofday ())) in let ps = Num.mult_num (Num.num_of_string "1000000000000") s in diff --git a/ocamlbuild/examples/example3/make.sh b/ocamlbuild/examples/example3/make.sh index 3588a713..e64152e1 100755 --- a/ocamlbuild/examples/example3/make.sh +++ b/ocamlbuild/examples/example3/make.sh @@ -1,5 +1,17 @@ #!/bin/sh +######################################################################### +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + set -e TARGET=epoch diff --git a/ocamlbuild/exit_codes.ml b/ocamlbuild/exit_codes.ml index 71c9f06f..10a3ac99 100644 --- a/ocamlbuild/exit_codes.ml +++ b/ocamlbuild/exit_codes.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/exit_codes.mli b/ocamlbuild/exit_codes.mli index a83a300b..cfbc3e25 100644 --- a/ocamlbuild/exit_codes.mli +++ b/ocamlbuild/exit_codes.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml index d359f781..8877e0c6 100644 --- a/ocamlbuild/fda.ml +++ b/ocamlbuild/fda.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/fda.mli b/ocamlbuild/fda.mli index c86d6857..40103f99 100644 --- a/ocamlbuild/fda.mli +++ b/ocamlbuild/fda.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index b5ef8781..199bc4fd 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -109,7 +110,7 @@ let rec query name = (* TODO: Improve to differenciate whether ocamlfind cannot be run or is not installed *) error Cannot_run_ocamlfind - | Lexers.Error s -> + | Lexers.Error (s,_) -> error (Cannot_parse_query (name, s)) let split_nl s = diff --git a/ocamlbuild/findlib.mli b/ocamlbuild/findlib.mli index 41275844..8bb29a80 100644 --- a/ocamlbuild/findlib.mli +++ b/ocamlbuild/findlib.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/flags.ml b/ocamlbuild/flags.ml index 0423ec43..9999f835 100644 --- a/ocamlbuild/flags.ml +++ b/ocamlbuild/flags.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/flags.mli b/ocamlbuild/flags.mli index 5e0e637d..13c5436a 100644 --- a/ocamlbuild/flags.mli +++ b/ocamlbuild/flags.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/glob.ml b/ocamlbuild/glob.ml index 7cb6127f..0bfa61f6 100644 --- a/ocamlbuild/glob.ml +++ b/ocamlbuild/glob.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -51,7 +52,7 @@ module NFA = | QEPSILON ;; - module IS = Set.Make(struct type t = int let compare = compare let print = Format.pp_print_int end);; + module IS = Set.Make(struct type t = int let compare (x:t) y = compare x y let print = Format.pp_print_int end);; module ISM = Map.Make(struct type t = IS.t let compare = IS.compare let print = IS.print end);; type machine = { @@ -72,8 +73,8 @@ module NFA = | QEPSILON -> epsilons := (q1,q2) :: !epsilons; q1 | QCLASS cl -> transitions := (q1,cl,q2) :: !transitions; q1 in - (* Construit les transitions correspondant au motif donné et arrivant - * sur l'état qf. Retourne l'état d'origine. *) + (* Construit les transitions correspondant au motif donne et arrivant + * sur l'etat qf. Retourne l'etat d'origine. *) let rec loop qf = function | Epsilon -> qf | Word u -> @@ -256,7 +257,7 @@ module Brute = | Word v -> String.length v = n && begin - let rec check j = j = n or (v.[j] = u.[i + j] && check (j + 1)) + let rec check j = j = n || (v.[j] = u.[i + j] && check (j + 1)) in check 0 end diff --git a/ocamlbuild/glob.mli b/ocamlbuild/glob.mli index f047c5b6..b13a6fc2 100644 --- a/ocamlbuild/glob.mli +++ b/ocamlbuild/glob.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/glob_ast.ml b/ocamlbuild/glob_ast.ml index a4efaedd..435033ad 100644 --- a/ocamlbuild/glob_ast.ml +++ b/ocamlbuild/glob_ast.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/glob_ast.mli b/ocamlbuild/glob_ast.mli index 9c778624..b6f7b282 100644 --- a/ocamlbuild/glob_ast.mli +++ b/ocamlbuild/glob_ast.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/glob_lexer.mli b/ocamlbuild/glob_lexer.mli index 245870ec..724c237c 100644 --- a/ocamlbuild/glob_lexer.mli +++ b/ocamlbuild/glob_lexer.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/glob_lexer.mll b/ocamlbuild/glob_lexer.mll index 05d199d6..5bc35c18 100644 --- a/ocamlbuild/glob_lexer.mll +++ b/ocamlbuild/glob_lexer.mll @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/hooks.ml b/ocamlbuild/hooks.ml index e7fd50d5..4dfcf292 100644 --- a/ocamlbuild/hooks.ml +++ b/ocamlbuild/hooks.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/hooks.mli b/ocamlbuild/hooks.mli index aced084d..92f9a0e7 100644 --- a/ocamlbuild/hooks.mli +++ b/ocamlbuild/hooks.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml index 33c01ed1..9a52cd94 100644 --- a/ocamlbuild/hygiene.ml +++ b/ocamlbuild/hygiene.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/hygiene.mli b/ocamlbuild/hygiene.mli index 33420382..1dd55f8a 100644 --- a/ocamlbuild/hygiene.mli +++ b/ocamlbuild/hygiene.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index bc5de4cf..ae4939aa 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -11,7 +12,7 @@ (* Original author: Nicolas Pouillard *) -exception Error of string +exception Error of (string * Lexing.position) type conf_values = { plus_tags : string list; @@ -35,7 +36,7 @@ val parse_environment_path : Lexing.lexbuf -> string list (* Same one, for Windows (PATH is ;-separated) *) val parse_environment_path_w : Lexing.lexbuf -> string list -val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf +val conf_lines : string option -> Lexing.lexbuf -> conf val path_scheme : bool -> Lexing.lexbuf -> [ `Word of string | `Var of (string * Glob.globber) diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 2206f862..12099feb 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -12,7 +13,10 @@ (* Original author: Nicolas Pouillard *) { -exception Error of string +exception Error of (string * Lexing.position) + +let error lexbuf fmt = Printf.ksprintf (fun s -> raise (Error (s,Lexing.lexeme_start_p lexbuf))) fmt + open Glob_ast type conf_values = @@ -41,45 +45,45 @@ let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])* rule ocamldep_output = parse | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } | eof { [] } - | _ { raise (Error "Expecting colon followed by space-separated module name list") } + | _ { error lexbuf "Expecting colon followed by space-separated module name list" } and space_sep_strings_nl = parse | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } - | space* newline { [] } - | _ { raise (Error "Expecting space-separated strings terminated with newline") } + | space* newline { Lexing.new_line lexbuf; [] } + | _ { error lexbuf "Expecting space-separated strings terminated with newline" } and space_sep_strings = parse | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } | space* newline? eof { [] } - | _ { raise (Error "Expecting space-separated strings") } + | _ { error lexbuf "Expecting space-separated strings" } and blank_sep_strings = parse | blank* '#' not_newline* newline { blank_sep_strings lexbuf } | blank* '#' not_newline* eof { [] } | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } | blank* eof { [] } - | _ { raise (Error "Expecting blank-separated strings") } + | _ { error lexbuf "Expecting blank-separated strings" } and comma_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting comma-separated strings (1)") } + | _ { error lexbuf "Expecting comma-separated strings (1)" } and comma_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting comma-separated strings (2)") } + | _ { error lexbuf "Expecting comma-separated strings (2)" } and comma_or_blank_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") } + | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" } and comma_or_blank_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } - | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } + | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" } and parse_environment_path_w = parse | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } @@ -88,7 +92,7 @@ and parse_environment_path_w = parse and parse_environment_path_aux_w = parse | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } | eof { [] } - | _ { raise (Error "Impossible: expecting colon-separated strings") } + | _ { error lexbuf "Impossible: expecting colon-separated strings" } and parse_environment_path = parse | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } @@ -97,31 +101,35 @@ and parse_environment_path = parse and parse_environment_path_aux = parse | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | eof { [] } - | _ { raise (Error "Impossible: expecting colon-separated strings") } + | _ { error lexbuf "Impossible: expecting colon-separated strings" } -and conf_lines dir pos err = parse - | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf } +and conf_lines dir = parse + | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } | space* '#' not_newline* eof { [] } - | space* newline { conf_lines dir (pos + 1) err lexbuf } + | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } | space* eof { [] } | space* (not_newline_nor_colon+ as k) space* ':' space* { - let bexpr = Glob.parse ?dir k in - let v1 = conf_value pos err empty lexbuf in - let v2 = conf_values pos err v1 lexbuf in - let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest + let bexpr = + try Glob.parse ?dir k + with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) + in + let v1 = conf_value empty lexbuf in + let v2 = conf_values v1 lexbuf in + Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *) + let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest } - | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) } + | _ { error lexbuf "Invalid line syntax" } -and conf_value pos err x = parse +and conf_value x = parse | '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } } | '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } } - | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) } + | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } -and conf_values pos err x = parse - | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf } +and conf_values x = parse + | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf } | (newline | eof) { x } - | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) } + | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" } and path_scheme patt_allowed = parse | ([^ '%' ]+ as prefix) @@ -132,14 +140,13 @@ and path_scheme patt_allowed = parse { if patt_allowed then let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf - else raise (Error( - Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" - var patt)) } + else + error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } | '%' { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf } | eof { [] } - | _ { raise (Error("Bad pathanme scheme")) } + | _ { error lexbuf "Bad pathanme scheme" } and unescape = parse | '\\' (['(' ')'] as c) { c :: unescape lexbuf } @@ -155,11 +162,11 @@ and ocamlfind_query = parse "linkopts:" space* (not_newline* as lo) newline+ "location:" space* (not_newline* as l) newline+ { n, d, v, a, lo, l } - | _ { raise (Error "Bad ocamlfind query") } + | _ { error lexbuf "Bad ocamlfind query" } and trim_blanks = parse | blank* (not_blank* as word) blank* { word } - | _ { raise (Error "Bad input for trim_blanks") } + | _ { error lexbuf "Bad input for trim_blanks" } and tag_gen = parse | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param } diff --git a/ocamlbuild/log.ml b/ocamlbuild/log.ml index 2fd2b2b1..380c9a59 100644 --- a/ocamlbuild/log.ml +++ b/ocamlbuild/log.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/log.mli b/ocamlbuild/log.mli index 8f4167bf..a414608a 100644 --- a/ocamlbuild/log.mli +++ b/ocamlbuild/log.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 3b9bd892..ecf4b579 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -65,12 +66,15 @@ let proceed () = Options.init (); if !Options.must_clean then clean (); Hooks.call_hook Hooks.After_options; - Plugin.execute_plugin_if_needed (); - - if !Options.targets = [] - && !Options.show_tags = [] - && not !Options.show_documentation - then raise Exit_silently; + let options_wd = Sys.getcwd () in + let first_run_for_plugin = + (* If we are in the first run before launching the plugin, we + should skip the user-visible operations (hygiene) that may need + information from the plugin to run as the user expects it. + + Note that we don't need to disable the [Hooks] call as they are + no-ops anyway, before any plugin has registered hooks. *) + Plugin.we_need_a_plugin () && not !Options.just_plugin in let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in @@ -97,6 +101,10 @@ let proceed () = (fun pkg -> Configuration.tag_any [Param_tags.make "package" pkg]) !Options.ocaml_pkgs; + begin match !Options.ocaml_syntax with + | Some syntax -> Configuration.tag_any [Param_tags.make "syntax" syntax] + | None -> () end; + let newpwd = Sys.getcwd () in Sys.chdir Pathname.pwd; let entry_include_dirs = ref [] in @@ -116,16 +124,20 @@ let proceed () = (List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_')) && (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs)) && begin - if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then + not (path_name <> Filename.current_dir_name && Pathname.is_directory path_name) + || begin let tags = tags_of_pathname path_name in - if Tags.mem "include" tags - || List.mem path_name !Options.include_dirs then + (if Tags.mem "include" tags + || List.mem path_name !Options.include_dirs then (entry_include_dirs := path_name :: !entry_include_dirs; true) else Tags.mem "traverse" tags || List.exists (Pathname.is_prefix path_name) !Options.include_dirs - || List.exists (Pathname.is_prefix path_name) target_dirs - else true + || List.exists (Pathname.is_prefix path_name) target_dirs) + && ((* beware: !Options.build_dir is an absolute directory *) + Pathname.normalize !Options.build_dir + <> Pathname.normalize (Pathname.pwd/path_name)) + end end end (Slurp.slurp Filename.current_dir_name) @@ -136,7 +148,7 @@ let proceed () = let tags = tags_of_pathname (path/name) in not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags) end entry in - if !Options.hygiene then + if !Options.hygiene && not first_run_for_plugin then Fda.inspect hygiene_entry else Slurp.force hygiene_entry; @@ -152,6 +164,15 @@ let proceed () = Ocaml_specific.init (); Hooks.call_hook Hooks.After_rules; + Sys.chdir options_wd; + Plugin.execute_plugin_if_needed (); + + (* [Param_tags.init ()] is called *after* the plugin is executed, as + some of the parametrized tags present in the _tags files parsed + will be declared by the plugin, and would therefore result in + "tag X does not expect a parameter" warnings if initialized + before. Note that [Plugin.rebuild_plugin_if_needed] is careful to + partially initialize the tags that it uses for plugin compilation. *) Param_tags.init (); Sys.chdir newpwd; @@ -276,8 +297,9 @@ let main () = | Ocaml_utils.Ocamldep_error msg -> Log.eprintf "Ocamldep error: %s" msg; exit rc_ocamldep_error - | Lexers.Error msg -> - Log.eprintf "Lexical analysis error: %s" msg; + | Lexers.Error (msg,pos) -> + let module L = Lexing in + Log.eprintf "%s, line %d, column %d: Lexing error: %s." pos.L.pos_fname pos.L.pos_lnum (pos.L.pos_cnum - pos.L.pos_bol) msg; exit rc_lexing_error | Arg.Bad msg -> Log.eprintf "%s" msg; diff --git a/ocamlbuild/main.mli b/ocamlbuild/main.mli index c401be7d..d9e781f8 100644 --- a/ocamlbuild/main.mli +++ b/ocamlbuild/main.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1 index 918c5981..1f0c6855 100644 --- a/ocamlbuild/man/ocamlbuild.1 +++ b/ocamlbuild/man/ocamlbuild.1 @@ -1,4 +1,5 @@ .\"***********************************************************************) +.\"* *) .\"* ocamlbuild *) .\"* *) .\"* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/misc/opentracer.ml b/ocamlbuild/misc/opentracer.ml index 38a13502..f6dcc1f3 100644 --- a/ocamlbuild/misc/opentracer.ml +++ b/ocamlbuild/misc/opentracer.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index a9478ab5..8de751f7 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -61,7 +62,7 @@ module Set = struct module type S = sig include Set.S - val find : (elt -> bool) -> t -> elt + val find_elt : (elt -> bool) -> t -> elt val map : (elt -> elt) -> t -> t val of_list : elt list -> t val print : formatter -> t -> unit @@ -70,7 +71,7 @@ module Set = struct module Make (M : OrderedTypePrintable) : S with type elt = M.t = struct include Set.Make(M) exception Found of elt - let find p set = + let find_elt p set = try iter begin fun elt -> if p elt then raise (Found elt) @@ -194,7 +195,7 @@ module String = struct and n = String.length v in m <= n && - let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in + let rec loop i = i = m || u.[i] = v.[i] && loop (i + 1) in loop 0 (* ***) @@ -204,7 +205,7 @@ module String = struct and n = String.length v in n <= m && - let rec loop i = i = n or u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in + let rec loop i = i = n || u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in loop 0 (* ***) @@ -402,3 +403,19 @@ let memo f = with Not_found -> let res = f x in (Hashtbl.add cache x res; res) + +let memo2 f = + let cache = Hashtbl.create 103 in + fun x y -> + try Hashtbl.find cache (x,y) + with Not_found -> + let res = f x y in + (Hashtbl.add cache (x,y) res; res) + +let memo3 f = + let cache = Hashtbl.create 103 in + fun x y z -> + try Hashtbl.find cache (x,y,z) + with Not_found -> + let res = f x y z in + (Hashtbl.add cache (x,y,z) res; res) diff --git a/ocamlbuild/my_std.mli b/ocamlbuild/my_std.mli index f2847db3..403c4e96 100644 --- a/ocamlbuild/my_std.mli +++ b/ocamlbuild/my_std.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml index a54f05bf..43692d32 100644 --- a/ocamlbuild/my_unix.ml +++ b/ocamlbuild/my_unix.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/my_unix.mli b/ocamlbuild/my_unix.mli index b1acd3a6..c7ee6e81 100644 --- a/ocamlbuild/my_unix.mli +++ b/ocamlbuild/my_unix.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_arch.ml b/ocamlbuild/ocaml_arch.ml index 5563dddd..cb5b7802 100644 --- a/ocamlbuild/ocaml_arch.ml +++ b/ocamlbuild/ocaml_arch.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_arch.mli b/ocamlbuild/ocaml_arch.mli index ffdc4edd..6739e8ff 100644 --- a/ocamlbuild/ocaml_arch.mli +++ b/ocamlbuild/ocaml_arch.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index 6a3b9ba6..39a68f8e 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -144,6 +145,12 @@ let rec prepare_link tag cmx extensions build = (if Pathname.exists (ml-.-"depends") then path_dependencies_of ml else []) (if Pathname.exists (mli-.-"depends") then path_dependencies_of mli else []) in + let modules = + if (modules = []) && (Pathname.exists (ml^"pack")) then + List.map (fun s -> (`mandatory, s)) (string_list_of_file (ml^"pack")) + else + modules + in if modules <> [] && not (Hashtbl.mem cache_prepare_link key) then let () = Hashtbl.add cache_prepare_link key true in let modules' = List.map (fun (_, x) -> expand_module include_dirs x extensions) modules in @@ -224,6 +231,9 @@ let byte_link_gen = link_gen "cmo" "cma" "cma" ["cmo"; "cmi"] let byte_link = byte_link_gen ocamlc_link_prog (fun tags -> tags++"ocaml"++"link"++"byte"++"program") +let byte_output_obj = byte_link_gen ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") + let byte_library_link = byte_link_gen byte_lib_linker byte_lib_linker_tags let byte_debug_link_gen = @@ -241,6 +251,9 @@ let native_link_gen linker = let native_link x = native_link_gen ocamlopt_link_prog (fun tags -> tags++"ocaml"++"link"++"native"++"program") x +let native_output_obj x = native_link_gen ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x + let native_library_link x = native_link_gen native_lib_linker native_lib_linker_tags x diff --git a/ocamlbuild/ocaml_compiler.mli b/ocamlbuild/ocaml_compiler.mli index 608f0334..24c3695c 100644 --- a/ocamlbuild/ocaml_compiler.mli +++ b/ocamlbuild/ocaml_compiler.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -40,10 +41,12 @@ val link_gen : (Tags.t -> Tags.t) -> string -> string -> Rule.action val byte_link : string -> string -> Rule.action +val byte_output_obj : string -> string -> Rule.action val byte_library_link : string -> string -> Rule.action val byte_debug_link : string -> string -> Rule.action val byte_debug_library_link : string -> string -> Rule.action val native_link : string -> string -> Rule.action +val native_output_obj : string -> string -> Rule.action val native_library_link : string -> string -> Rule.action val native_shared_library_link : ?tags:(string list) -> string -> string -> Rule.action val native_profile_link : string -> string -> Rule.action diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml index c6c8efeb..de2c11fa 100644 --- a/ocamlbuild/ocaml_dependencies.ml +++ b/ocamlbuild/ocaml_dependencies.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_dependencies.mli b/ocamlbuild/ocaml_dependencies.mli index 5c1ebfe6..b9e7812b 100644 --- a/ocamlbuild/ocaml_dependencies.mli +++ b/ocamlbuild/ocaml_dependencies.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 05343de1..65fb55d1 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -159,6 +160,18 @@ rule "ocaml: cmo* -> byte" ~dep:"%.cmo" (Ocaml_compiler.byte_link "%.cmo" "%.byte");; +rule "ocaml: cmo* -> byte.o" + ~tags:["ocaml"; "byte"; "link"; "output_obj" ] + ~prod:"%.byte.o" + ~dep:"%.cmo" + (Ocaml_compiler.byte_output_obj "%.cmo" "%.byte.o");; + +rule "ocaml: cmo* -> byte.c" + ~tags:["ocaml"; "byte"; "link"; "output_obj" ] + ~prod:"%.byte.c" + ~dep:"%.cmo" + (Ocaml_compiler.byte_output_obj "%.cmo" "%.byte.c");; + rule "ocaml: p.cmx* & p.o* -> p.native" ~tags:["ocaml"; "native"; "profile"; "program"] ~prod:"%.p.native" @@ -171,6 +184,12 @@ rule "ocaml: cmx* & o* -> native" ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_link "%.cmx" "%.native");; +rule "ocaml: cmx* & o* -> native.o" + ~tags:["ocaml"; "native"; "output_obj" ] + ~prod:"%.native.o" + ~deps:["%.cmx"; x_o] + (Ocaml_compiler.native_output_obj "%.cmx" "%.native.o");; + rule "ocaml: mllib & d.cmo* -> d.cma" ~tags:["ocaml"; "byte"; "debug"; "library"] ~prod:"%.d.cma" @@ -196,8 +215,11 @@ rule "ocaml: cmo* -> cma" (Ocaml_compiler.byte_library_link "%.cmo" "%.cma");; rule "ocaml C stubs: clib & (o|obj)* -> (a|lib) & (so|dll)" - ~prods:["%(path:<**/>)lib%(libname:<*> and not <*.*>)"-.-ext_lib; - "%(path:<**/>)dll%(libname:<*> and not <*.*>)"-.-ext_dll] + ~prods:(["%(path:<**/>)lib%(libname:<*> and not <*.*>)"-.-ext_lib] @ + if Ocamlbuild_Myocamlbuild_config.supports_shared_libraries then + ["%(path:<**/>)dll%(libname:<*> and not <*.*>)"-.-ext_dll] + else + []) ~dep:"%(path)lib%(libname).clib" (C_tools.link_C_library "%(path)lib%(libname).clib" ("%(path)lib%(libname)"-.-ext_lib) "%(path)%(libname)");; @@ -482,7 +504,11 @@ let camlp4_flags camlp4s = flag ["ocaml"; "pp"; camlp4] (A camlp4) end camlp4s;; -camlp4_flags ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"; "camlp4oof"];; +let p4_series = ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"; "camlp4oof"];; +let p4_opt_series = List.map (fun f -> f ^ ".opt") p4_series;; + +camlp4_flags p4_series;; +camlp4_flags p4_opt_series;; let camlp4_flags' camlp4s = List.iter begin fun (camlp4, flags) -> @@ -526,9 +552,15 @@ flag ["ocaml"; "link"; "native"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; +flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");; +flag ["ocaml"; "short_paths"; "compile"] (A "-short-paths");; +flag ["ocaml"; "short_paths"; "infer_interface"] (A "-short-paths");; flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");; flag ["ocaml"; "rectypes"; "infer_interface"] (A "-rectypes");; flag ["ocaml"; "rectypes"; "doc"] (A "-rectypes");; +flag ["ocaml"; "rectypes"; "pack"] (A "-rectypes");; +flag ["ocaml"; "principal"; "compile"] (A "-principal");; +flag ["ocaml"; "principal"; "infer_interface"] (A "-principal");; flag ["ocaml"; "linkall"; "link"] (A "-linkall");; flag ["ocaml"; "link"; "profile"; "native"] (A "-p");; flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; @@ -537,14 +569,13 @@ flag ["ocaml"; "compile"; "profile"; "native"] (A "-p");; (* threads, with or without findlib *) flag ["ocaml"; "compile"; "thread"] (A "-thread");; +flag ["ocaml"; "link"; "thread"] (A "-thread");; if not !Options.use_ocamlfind then begin flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]); - flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]); - flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"]); - flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (S[A "threads.cmxa"; A "-thread"]); - flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (S[A "threads.cma"; A "-thread"]) -end else begin - flag ["ocaml"; "link"; "thread"; "program"] (A "-thread") + flag ["ocaml"; "link"; "thread"; "native"; "program"] (A "threads.cmxa"); + flag ["ocaml"; "link"; "thread"; "byte"; "program"] (A "threads.cma"); + flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (A "threads.cmxa"); + flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (A "threads.cma"); end;; flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");; @@ -563,7 +594,10 @@ let ocaml_warn_flag c = flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase c)] (S[A"-warn-error"; A (sprintf "%c" (Char.lowercase c))]);; -List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'Y'; 'Z'; 'X'];; +List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'K'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'X'; 'Y'; 'Z'];; + +flag ["ocaml"; "compile"; "strict-sequence"] (A "-strict-sequence");; +flag ["ocaml"; "compile"; "strict_sequence"] (A "-strict-sequence");; flag ["ocaml"; "doc"; "docdir"; "extension:html"] (A"-html");; flag ["ocaml"; "doc"; "docdir"; "manpage"] (A"-man");; diff --git a/ocamlbuild/ocaml_specific.mli b/ocamlbuild/ocaml_specific.mli index 42e512c7..54cd7fac 100644 --- a/ocamlbuild/ocaml_specific.mli +++ b/ocamlbuild/ocaml_specific.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index f68aff42..f4019c7a 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -99,11 +100,13 @@ let infer_interface ml mli env build = let menhir mly env build = let mly = env mly in let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in + let tags = tags_of_pathname mly in + let ocamlc_tags = tags++"ocaml"++"byte"++"compile" in + let menhir_tags = tags++"ocaml"++"parser"++"menhir" in Ocaml_compiler.prepare_compile build mly; Cmd(S[menhir; - A"--ocamlc"; Quote(S[!Options.ocamlc; ocaml_include_flags mly]); - T(tags_of_pathname mly++"ocaml"++"parser"++"menhir"); - A"--infer"; Px mly]) + A"--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mly]); + T menhir_tags; A"--infer"; Px mly]) let ocamldoc_c tags arg odoc = let tags = tags++"ocaml" in diff --git a/ocamlbuild/ocaml_tools.mli b/ocamlbuild/ocaml_tools.mli index 542573de..38d36e3a 100644 --- a/ocamlbuild/ocaml_tools.mli +++ b/ocamlbuild/ocaml_tools.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 7726825c..b35ad679 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -64,17 +65,18 @@ let path_importance path x = end else if ignore_stdlib x then `just_try else `mandatory -let expand_module include_dirs module_name exts = - let dirname = Pathname.dirname module_name in - let basename = Pathname.basename module_name in - let module_name_cap = dirname/(String.capitalize basename) in - let module_name_uncap = dirname/(String.uncapitalize basename) in - List.fold_right begin fun include_dir -> - List.fold_right begin fun ext acc -> - include_dir/(module_name_uncap-.-ext) :: - include_dir/(module_name_cap-.-ext) :: acc - end exts - end include_dirs [] +let expand_module = + memo3 (fun include_dirs module_name exts -> + let dirname = Pathname.dirname module_name in + let basename = Pathname.basename module_name in + let module_name_cap = dirname/(String.capitalize basename) in + let module_name_uncap = dirname/(String.uncapitalize basename) in + List.fold_right begin fun include_dir -> + List.fold_right begin fun ext acc -> + include_dir/(module_name_uncap-.-ext) :: + include_dir/(module_name_cap-.-ext) :: acc + end exts + end include_dirs []) let string_list_of_file file = with_input_file file begin fun ic -> @@ -144,7 +146,7 @@ let read_path_dependencies = with_input_file depends begin fun ic -> let ocamldep_output = try Lexers.ocamldep_output (Lexing.from_channel ic) - with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in + with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in let deps = List.fold_right begin fun (path, deps) acc -> let module_name' = module_name_of_pathname path in diff --git a/ocamlbuild/ocaml_utils.mli b/ocamlbuild/ocaml_utils.mli index 259a527f..5154a1ac 100644 --- a/ocamlbuild/ocaml_utils.mli +++ b/ocamlbuild/ocaml_utils.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild.ml b/ocamlbuild/ocamlbuild.ml index d3b82518..ce0f56f4 100644 --- a/ocamlbuild/ocamlbuild.ml +++ b/ocamlbuild/ocamlbuild.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild.mli b/ocamlbuild/ocamlbuild.mli index 7e5aa0bf..83cab501 100644 --- a/ocamlbuild/ocamlbuild.mli +++ b/ocamlbuild/ocamlbuild.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild.odocl b/ocamlbuild/ocamlbuild.odocl index c3b04f06..fe0c1730 100644 --- a/ocamlbuild/ocamlbuild.odocl +++ b/ocamlbuild/ocamlbuild.odocl @@ -1,7 +1,6 @@ Log My_unix My_std -Std_signatures Signatures Shell Display diff --git a/ocamlbuild/ocamlbuild_executor.ml b/ocamlbuild/ocamlbuild_executor.ml index 9798e052..53fcad12 100644 --- a/ocamlbuild/ocamlbuild_executor.ml +++ b/ocamlbuild/ocamlbuild_executor.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_executor.mli b/ocamlbuild/ocamlbuild_executor.mli index fc25badc..063b91ee 100644 --- a/ocamlbuild/ocamlbuild_executor.mli +++ b/ocamlbuild/ocamlbuild_executor.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_plugin.ml b/ocamlbuild/ocamlbuild_plugin.ml index ccbc0798..9f0de1be 100644 --- a/ocamlbuild/ocamlbuild_plugin.ml +++ b/ocamlbuild/ocamlbuild_plugin.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_plugin.mli b/ocamlbuild/ocamlbuild_plugin.mli index 0844b4d7..f94f325f 100644 --- a/ocamlbuild/ocamlbuild_plugin.mli +++ b/ocamlbuild/ocamlbuild_plugin.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_unix_plugin.ml b/ocamlbuild/ocamlbuild_unix_plugin.ml index cb2f0101..9966c4dc 100644 --- a/ocamlbuild/ocamlbuild_unix_plugin.ml +++ b/ocamlbuild/ocamlbuild_unix_plugin.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_unix_plugin.mli b/ocamlbuild/ocamlbuild_unix_plugin.mli index 24269e5a..ecc4f62d 100644 --- a/ocamlbuild/ocamlbuild_unix_plugin.mli +++ b/ocamlbuild/ocamlbuild_unix_plugin.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_where.ml b/ocamlbuild/ocamlbuild_where.ml index d65b41ed..a05230a5 100644 --- a/ocamlbuild/ocamlbuild_where.ml +++ b/ocamlbuild/ocamlbuild_where.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuild_where.mli b/ocamlbuild/ocamlbuild_where.mli index eb4c0727..6fa56787 100644 --- a/ocamlbuild/ocamlbuild_where.mli +++ b/ocamlbuild/ocamlbuild_where.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuildlight.ml b/ocamlbuild/ocamlbuildlight.ml index 7fabd81d..f8226875 100644 --- a/ocamlbuild/ocamlbuildlight.ml +++ b/ocamlbuild/ocamlbuildlight.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ocamlbuildlight.mli b/ocamlbuild/ocamlbuildlight.mli index 38ffd979..9f4d063d 100644 --- a/ocamlbuild/ocamlbuildlight.mli +++ b/ocamlbuild/ocamlbuildlight.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 1be4b636..2fe9e0d0 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -39,24 +40,42 @@ let use_menhir = ref false let catch_errors = ref true let use_ocamlfind = ref false -let mk_virtual_solvers = +(* Currently only ocamlfind and menhir is defined as no-core tool, + perhaps later we need something better *) +let is_core_tool = function "ocamlfind" | "menhir" -> false | _ -> true + +let find_tool cmd = let dir = Ocamlbuild_where.bindir in + let core_tool = is_core_tool cmd in + let opt = cmd ^ ".opt" in + let search_in_path = memo Command.search_in_path in + if sys_file_exists !dir then + let long = filename_concat !dir cmd in + let long_opt = long ^ ".opt" in + (* This defines how the command will be found *) + let choices = + [(fun () -> if file_or_exe_exists long_opt then Some long_opt else None); + (fun () -> if file_or_exe_exists long then Some long else None)] in + (* For non core tool the preference is too look at PATH first *) + let choices' = + [fun () -> + try let _ = search_in_path opt in Some opt + with Not_found -> Some cmd] + in + let choices = if core_tool then choices @ choices' else choices' @ choices in + try + match (List.find (fun choice -> not (choice () = None)) choices) () with + Some cmd -> cmd + | None -> raise Not_found + with Not_found -> failwith (Printf.sprintf "Can't find tool: %s" cmd) + else + try let _ = search_in_path opt in opt + with Not_found -> cmd + +let mk_virtual_solvers = List.iter begin fun cmd -> - let opt = cmd ^ ".opt" in - let a_opt = A opt in - let a_cmd = A cmd in - let search_in_path = memo Command.search_in_path in let solver () = - if sys_file_exists !dir then - let long = filename_concat !dir cmd in - let long_opt = long ^ ".opt" in - if file_or_exe_exists long_opt then A long_opt - else if file_or_exe_exists long then A long - else try let _ = search_in_path opt in a_opt - with Not_found -> a_cmd - else - try let _ = search_in_path opt in a_opt - with Not_found -> a_cmd + A (find_tool cmd) in Command.setup_virtual_command_solver (String.uppercase cmd) solver end @@ -87,6 +106,7 @@ let targets_internal = ref [] let ocaml_libs_internal = ref [] let ocaml_mods_internal = ref [] let ocaml_pkgs_internal = ref [] +let ocaml_syntax = ref None let ocaml_lflags_internal = ref [] let ocaml_cflags_internal = ref [] let ocaml_docflags_internal = ref [] @@ -98,6 +118,7 @@ let ignore_list_internal = ref [] let tags_internal = ref [["quiet"]] let tag_lines_internal = ref [] let show_tags_internal = ref [] +let plugin_tags_internal = ref [] let log_file_internal = ref "_log" let my_include_dirs = ref [[Filename.current_dir_name]] @@ -140,7 +161,7 @@ let spec = ref ( "-vnum", Unit (fun () -> print_endline Sys.ocaml_version; raise Exit_OK), " Display the version number"; "-quiet", Unit (fun () -> Log.level := 0), " Make as quiet as possible"; - "-verbose", Int (fun i -> Log.level := i + 2), " Set the verbosity level"; + "-verbose", Int (fun i -> Log.classic_display := true; Log.level := i + 2), " Set the verbosity level"; "-documentation", Set show_documentation, " Show rules and flags"; "-log", Set_string log_file_internal, " Set log file"; "-no-log", Unit (fun () -> log_file_internal := ""), " No log file"; @@ -159,6 +180,7 @@ let spec = ref ( "-pkg", String (add_to' ocaml_pkgs_internal), " Link to this ocaml findlib package"; "-pkgs", String (add_to ocaml_pkgs_internal), " (idem)"; "-package", String (add_to' ocaml_pkgs_internal), " (idem)"; + "-syntax", String (fun syntax -> ocaml_syntax := Some syntax), " Specify syntax using ocamlfind"; "-lflag", String (add_to' ocaml_lflags_internal), " Add to ocamlc link flags"; "-lflags", String (add_to ocaml_lflags_internal), " (idem)"; "-cflag", String (add_to' ocaml_cflags_internal), " Add to ocamlc compile flags"; @@ -173,6 +195,8 @@ let spec = ref ( "-pp", String (add_to ocaml_ppflags_internal), " (idem)"; "-tag", String (add_to' tags_internal), " Add to default tags"; "-tags", String (add_to tags_internal), " (idem)"; + "-plugin-tag", String (add_to' plugin_tags_internal), " Use this tag when compiling the myocamlbuild.ml plugin"; + "-plugin-tags", String (add_to plugin_tags_internal), " (idem)"; "-tag-line", String (add_to' tag_lines_internal), " Use this line of tags (as in _tags)"; "-show-tags", String (add_to' show_tags_internal), " Show tags that applies on that pathname"; @@ -200,7 +224,7 @@ let spec = ref ( "-install-lib-dir", Set_string Ocamlbuild_where.libdir, " Set the install library directory"; "-install-bin-dir", Set_string Ocamlbuild_where.bindir, " Set the install binary directory"; "-where", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), " Display the install library directory"; - + "-which", String (fun cmd -> print_endline (find_tool cmd); raise Exit_OK), " Display path to the tool command"; "-ocamlc", set_cmd ocamlc, " Set the OCaml bytecode compiler"; "-ocamlopt", set_cmd ocamlopt, " Set the OCaml native compiler"; "-ocamldep", set_cmd ocamldep, " Set the OCaml dependency tool"; @@ -235,6 +259,7 @@ let ignore_list = ref [] let tags = ref [] let tag_lines = ref [] let show_tags = ref [] +let plugin_tags = ref [] let init () = let anon_fun = add_to' targets_internal in @@ -284,6 +309,7 @@ let init () = reorder tag_lines tag_lines_internal; reorder ignore_list ignore_list_internal; reorder show_tags show_tags_internal; + reorder plugin_tags plugin_tags_internal; let check_dir dir = if Filename.is_implicit dir then diff --git a/ocamlbuild/options.mli b/ocamlbuild/options.mli index 7e07748b..b450c845 100644 --- a/ocamlbuild/options.mli +++ b/ocamlbuild/options.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -14,5 +15,12 @@ include Signatures.OPTIONS with type command_spec = Command.spec +(* this option is not in Signatures.OPTIONS yet because adding tags to + the compilation of the plugin is a recent feature that may still be + subject to change, so the interface may not be stable; besides, + there is obviously little to gain from tweaking that option from + inside the plugin itself... *) +val plugin_tags : string list ref + val entry : bool Slurp.entry option ref val init : unit -> unit diff --git a/ocamlbuild/param_tags.ml b/ocamlbuild/param_tags.ml index 94e96788..2d4f4ae6 100644 --- a/ocamlbuild/param_tags.ml +++ b/ocamlbuild/param_tags.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -31,22 +32,26 @@ let only_once f = let declare name action = Hashtbl.add declared_tags name (only_once action) -let acknowledge tag = - let tag = Lexers.tag_gen (Lexing.from_string tag) in - acknowledged_tags := tag :: !acknowledged_tags +let parse tag = Lexers.tag_gen (Lexing.from_string tag) +let acknowledge tag = + acknowledged_tags := parse tag :: !acknowledged_tags -let really_acknowledge (name, param) = +let really_acknowledge ?(quiet=false) (name, param) = match param with | None -> - if Hashtbl.mem declared_tags name then + if Hashtbl.mem declared_tags name && not quiet then Log.eprintf "Warning: tag %S expects a parameter" name | Some param -> let actions = List.rev (Hashtbl.find_all declared_tags name) in - if actions = [] then - Log.eprintf "Warning: tag %S does not expect a parameter, but is used with parameter %S" name param; + if actions = [] && not quiet then + Log.eprintf "Warning: tag %S does not expect a parameter, \ + but is used with parameter %S" name param; List.iter (fun f -> f param) actions +let partial_init ?quiet tags = + Tags.iter (fun tag -> really_acknowledge ?quiet (parse tag)) tags + let init () = List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags) diff --git a/ocamlbuild/param_tags.mli b/ocamlbuild/param_tags.mli index a0047af1..3b978fa7 100644 --- a/ocamlbuild/param_tags.mli +++ b/ocamlbuild/param_tags.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -31,10 +32,17 @@ acknowledged parameter. *) val init: unit -> unit (** Initialize parameterized tags. + +This will make effective all instantiations [foo(bar)] such that the +parametrized tag [foo] has been [declare]d and [foo(bar)] has been +[acknowledge]d after the last [init] call. *) + +val partial_init: ?quiet:bool -> Tags.t -> unit +(** Initialize a list of tags -Call this function once all tags have been [declare]d and [acknowledge]d. -If you [declare] or [acknowledge] a tag after having called [init], this will -have no effect. [init] should only be called once. *) +This will make effective the instances [foo(bar)] appearing +in the given tag list, instead of those that have been +[acknowledged] previously. This is for system use only. *) val make: Tags.elt -> string -> Tags.elt (** Make a parameterized tag instance. diff --git a/ocamlbuild/pathname.ml b/ocamlbuild/pathname.ml index d535488d..d0c73726 100644 --- a/ocamlbuild/pathname.ml +++ b/ocamlbuild/pathname.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -23,7 +24,7 @@ let print_strings = List.print String.print let concat = filename_concat -let compare = compare +let compare (x:t) y = compare x y let print = pp_print_string diff --git a/ocamlbuild/pathname.mli b/ocamlbuild/pathname.mli index 1ba9badc..4f77e6a4 100644 --- a/ocamlbuild/pathname.mli +++ b/ocamlbuild/pathname.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index 4180755b..6e533bb9 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -21,18 +22,22 @@ open Tools open Command ;; -module Make(U:sig end) = - struct - let plugin = "myocamlbuild" - let plugin_file = plugin^".ml" - let plugin_config_file = plugin^"_config.ml" - let plugin_config_file_interface = plugin^"_config.mli" - let we_have_a_config_file = sys_file_exists plugin_config_file - let we_need_a_plugin = !Options.plugin && sys_file_exists plugin_file - let we_have_a_plugin = sys_file_exists ((!Options.build_dir/plugin)^(!Options.exe)) - let we_have_a_config_file_interface = sys_file_exists plugin_config_file_interface +let plugin = "myocamlbuild" +let plugin_file = plugin^".ml" +let plugin_config_file = plugin^"_config.ml" +let plugin_config_file_interface = plugin^"_config.mli" +let we_need_a_plugin () = !Options.plugin && sys_file_exists plugin_file +let we_have_a_plugin () = sys_file_exists ((!Options.build_dir/plugin)^(!Options.exe)) +let we_have_a_config_file () = sys_file_exists plugin_config_file +let we_have_a_config_file_interface () = sys_file_exists plugin_config_file_interface +module Make(U:sig end) = + struct + let we_need_a_plugin = we_need_a_plugin () + let we_have_a_plugin = we_have_a_plugin () + let we_have_a_config_file = we_have_a_config_file () + let we_have_a_config_file_interface = we_have_a_config_file_interface () let up_to_date_or_copy fn = let fn' = !Options.build_dir/fn in Pathname.exists fn && @@ -44,14 +49,10 @@ module Make(U:sig end) = end end - let profiling = Tags.mem "profile" (tags_of_pathname plugin_file) - - let debugging = Tags.mem "debug" (tags_of_pathname plugin_file) - let rebuild_plugin_if_needed () = let a = up_to_date_or_copy plugin_file in - let b = (not we_have_a_config_file) or up_to_date_or_copy plugin_config_file in - let c = (not we_have_a_config_file_interface) or up_to_date_or_copy plugin_config_file_interface in + let b = (not we_have_a_config_file) || up_to_date_or_copy plugin_config_file in + let c = (not we_have_a_config_file_interface) || up_to_date_or_copy plugin_config_file_interface in if a && b && c && we_have_a_plugin then () (* Up to date *) (* FIXME: remove ocamlbuild_config.ml in _build/ if removed in parent *) @@ -68,32 +69,169 @@ module Make(U:sig end) = S[P plugin_config_file_interface; P plugin_config_file] else P plugin_config_file else N in - let cma, cmo, more_options, compiler = + + let cma, cmo, compiler, byte_or_native = if !Options.native_plugin then - "cmxa", "cmx", (if profiling then A"-p" else N), !Options.ocamlopt + "cmxa", "cmx", !Options.ocamlopt, "native" else - "cma", "cmo", (if debugging then A"-g" else N), !Options.ocamlc + "cma", "cmo", !Options.ocamlc, "byte" in - let ocamlbuildlib, ocamlbuild, libs = - if (not !Options.native_plugin) && !*My_unix.is_degraded then - "ocamlbuildlightlib", "ocamlbuildlight", N - else - "ocamlbuildlib", "ocamlbuild", A("unix"-.-cma) + + + let (unix_spec, ocamlbuild_lib_spec, ocamlbuild_module_spec) = + + let use_light_mode = + not !Options.native_plugin && !*My_unix.is_degraded in + let use_ocamlfind_pkgs = + !Options.use_ocamlfind && !Options.plugin_tags <> [] in + (* The plugin has the following dependencies that must be + included during compilation: + + - unix.cmxa, if it is available + - ocamlbuildlib.cm{a,xa}, the library part of ocamlbuild + - ocamlbuild.cm{o,x}, the module that performs the + initialization work of the ocamlbuild executable, using + modules of ocamlbuildlib.cmxa + + We pass all this stuff to the compilation command for the + plugin, with two independent important details to handle: + + (1) ocamlbuild is designed to still work in environments + where Unix is not available for some reason; in this + case, we should not link unix, and use the + "ocamlbuildlight.cmo" initialization module, which runs + a "light" version of ocamlbuild without unix. There is + also an ocamlbuildlightlib.cma archive to be used in that + case. + + The boolean variable [use_light_mode] tells us whether we + are in this unix-deprived scenario. + + (2) there are risks of compilation error due to + double-linking of native modules when the user passes its + own tags to the plugin compilation process (as was added + to support modular construction of + ocamlbuild plugins). Indeed, if we hard-code linking to + unix.cmxa in all cases, and the user + enables -use-ocamlfind and + passes -plugin-tag "package(unix)" (or package(foo) for + any foo which depends on unix), the command-line finally + executed will be + + ocamlfind ocamlopt unix.cmxa -package unix myocamlbuild.ml + + which fails with a compilation error due to doubly-passed + native modules. + + To sanest way to solve this problem at the ocamlbuild level + is to pass "-package unix" instead of unix.cmxa when we + detect that such a situation may happen. OCamlfind will see + that the same package is demanded twice, and only request + it once to the compiler. Similarly, we use "-package + ocamlbuild" instead of linking ocamlbuildlib.cmxa[1]. + + We switch to this behavior when two conditions, embodied in + the boolean variable [use_ocamlfind_pkgs], are met: + (a) use-ocamlfind is enabled + (b) the user is passing some plugin tags + + Condition (a) is overly conservative as the double-linking + issue may also happen in non-ocamlfind situations, such as + "-plugin-tags use_unix" -- but it's unclear how one would + avoid the issue in that case, except by documenting that + people should not do that, or getting rid of the + hard-linking logic entirely, with the corresponding risks + of regression. + + Condition (b) should not be necessary (we expect using + ocamlfind packages to work whenever ocamlfind + is available), but allows the behavior in absence + of -plugin-tags to be completely unchanged, to reassure us + about potential regressions introduced by this option. + + [1]: we may wonder whether to use "-package ocamlbuildlight" + in unix-deprived situations, but currently ocamlfind + doesn't know about the ocamlbuildlight library. As + a compromise we always use "-package ocamlbuild" when + use_ocamlfind_pkgs is set. An ocamlfind and -plugin-tags + user in unix-deprived environment may want to mutate the + META of ocamlbuild to point to ocamlbuildlightlib instead + of ocamlbuildlib. + *) + + let unix_lib = + if use_ocamlfind_pkgs then `Package "unix" + else if use_light_mode then `Nothing + else `Lib "unix" in + + let ocamlbuild_lib = + if use_ocamlfind_pkgs then `Package "ocamlbuild" + else if use_light_mode then `Local_lib "ocamlbuildlightlib" + else `Local_lib "ocamlbuildlib" in + + let ocamlbuild_module = + if use_light_mode then `Local_mod "ocamlbuildlight" + else `Local_mod "ocamlbuild" in + + let dir = !Ocamlbuild_where.libdir in + let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in + + let in_dir file = + let path = dir/file in + if not (sys_file_exists path) then failwith + (sprintf "Cannot find %S in ocamlbuild -where directory" file); + path in + + let spec = function + | `Nothing -> N + | `Package pkg -> S[A "-package"; A pkg] + | `Lib lib -> P (lib -.- cma) + | `Local_lib llib -> S [A "-I"; A dir; P (in_dir (llib -.- cma))] + | `Local_mod lmod -> P (in_dir (lmod -.- cmo)) in + + (spec unix_lib, spec ocamlbuild_lib, spec ocamlbuild_module) in - let ocamlbuildlib = ocamlbuildlib-.-cma in - let ocamlbuild = ocamlbuild-.-cmo in - let dir = !Ocamlbuild_where.libdir in - if not (sys_file_exists (dir/ocamlbuildlib)) then - failwith (sprintf "Cannot find %S in ocamlbuild -where directory" ocamlbuildlib); - let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in + + let plugin_tags = + Tags.of_list !Options.plugin_tags + ++ "ocaml" ++ "program" ++ "link" ++ byte_or_native in + + (* The plugin is compiled before [Param_tags.init()] is called + globally, which means that parametrized tags have not been + made effective yet. The [partial_init] calls below initializes + precisely those that will be used during the compilation of + the plugin, and no more. + *) + Param_tags.partial_init plugin_tags; + let cmd = - Cmd(S[compiler; A"-I"; P dir; libs; more_options; - P(dir/ocamlbuildlib); plugin_config; P plugin_file; - P(dir/ocamlbuild); A"-o"; Px (plugin^(!Options.exe))]) + (* The argument order is important: we carefully put the + plugin source files before the ocamlbuild.cm{o,x} module + doing the main initialization, so that user global + side-effects (setting options, installing flags..) are + performed brefore ocamlbuild's main routine. This is + a fragile thing to rely upon and we insist that our users + use the more robust [dispatch] registration instead, but + we still aren't going to break that now. + + For the same reason we place the user plugin-tags after + the plugin libraries (in case a tag would, say, inject + a .cmo that also relies on them), but before the main + plugin source file and ocamlbuild's initialization. *) + Cmd(S[compiler; + unix_spec; ocamlbuild_lib_spec; + T plugin_tags; + plugin_config; P plugin_file; + ocamlbuild_module_spec; + A"-o"; Px (plugin^(!Options.exe))]) in Shell.chdir !Options.build_dir; Shell.rm_f (plugin^(!Options.exe)); - Command.execute cmd + Command.execute cmd; + if !Options.just_plugin then begin + Log.finish (); + raise Exit_OK; + end; end let execute_plugin_if_needed () = @@ -101,13 +239,14 @@ module Make(U:sig end) = begin rebuild_plugin_if_needed (); Shell.chdir Pathname.pwd; - if not !Options.just_plugin then - let runner = if !Options.native_plugin then N else !Options.ocamlrun in - let argv = List.tl (Array.to_list Sys.argv) in - let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe)); - A"-no-plugin"; atomize (List.filter (fun s -> s <> "-plugin-option") argv)] in - let () = Log.finish () in - raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec))) + let runner = if !Options.native_plugin then N else !Options.ocamlrun in + let argv = List.tl (Array.to_list Sys.argv) in + let passed_argv = List.filter (fun s -> s <> "-plugin-option") argv in + let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe)); + A"-no-plugin"; atomize passed_argv] in + Log.finish (); + let rc = sys_command (Command.string_of_command_spec spec) in + raise (Exit_silently_with_code rc); end else () diff --git a/ocamlbuild/plugin.mli b/ocamlbuild/plugin.mli index 863de8df..37d135a1 100644 --- a/ocamlbuild/plugin.mli +++ b/ocamlbuild/plugin.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -14,3 +15,4 @@ (* Plugin *) val execute_plugin_if_needed : unit -> unit +val we_need_a_plugin : unit -> bool diff --git a/ocamlbuild/ppcache.ml b/ocamlbuild/ppcache.ml index 1b576004..2682f3e1 100644 --- a/ocamlbuild/ppcache.ml +++ b/ocamlbuild/ppcache.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/ppcache.mli b/ocamlbuild/ppcache.mli index d59015f5..35f3614b 100644 --- a/ocamlbuild/ppcache.mli +++ b/ocamlbuild/ppcache.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/report.ml b/ocamlbuild/report.ml index e9c5d503..439a270f 100644 --- a/ocamlbuild/report.ml +++ b/ocamlbuild/report.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/report.mli b/ocamlbuild/report.mli index 16785d70..13448558 100644 --- a/ocamlbuild/report.mli +++ b/ocamlbuild/report.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml index ed90d1cf..4121d194 100644 --- a/ocamlbuild/resource.ml +++ b/ocamlbuild/resource.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -376,7 +377,7 @@ end = struct List.map begin fun x -> match x with | A atom -> atom - | V(var, _) -> List.assoc var env + | V(var, _) -> try List.assoc var env with Not_found -> (* unbound variable *) "" end s end end diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli index 4822768b..0ec15d36 100644 --- a/ocamlbuild/resource.mli +++ b/ocamlbuild/resource.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/rule.ml b/ocamlbuild/rule.ml index 8352f6ae..7cef2fde 100644 --- a/ocamlbuild/rule.ml +++ b/ocamlbuild/rule.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -160,7 +161,7 @@ let call builder r = begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with | Some r -> (`cache_miss_changed_dep r, false) | _ -> - begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with + begin match exists2 Resources.find_elt Resource.Cache.resource_has_changed dyndeps with | Some r -> (`cache_miss_changed_dyn_dep r, false) | _ -> begin match cached_digest r with @@ -261,11 +262,11 @@ let rule name ?(tags=[]) ?(prods=[]) ?(deps=[]) ?prod ?dep ?stamp ?(insert = `bo List.fold_right begin fun x acc -> let r = import x in if List.mem r acc then - failwith (sprintf "in rule %s, multiple occurences of the resource %s" name x) + failwith (sprintf "in rule %s, multiple occurrences of the resource %s" name x) else r :: acc end xs init in - if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produce nothing"); + if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produces nothing"); let stamp, prods = match stamp with | None -> None, prods diff --git a/ocamlbuild/rule.mli b/ocamlbuild/rule.mli index 16af0f6f..0acb125c 100644 --- a/ocamlbuild/rule.mli +++ b/ocamlbuild/rule.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml index 3fbeb81a..2809569f 100644 --- a/ocamlbuild/shell.ml +++ b/ocamlbuild/shell.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -65,9 +66,9 @@ let cp_pf src dest = reset_filesys_cache_for_file dest; run["cp";"-pf";src;dest] dest -(* L'Arrêté du 2007-03-07 prend en consideration +(* L'Arrete du 2007-03-07 prend en consideration differement les archives. Pour les autres fichiers - le décret du 2007-02-01 est toujours valable :-) *) + le decret du 2007-02-01 est toujours valable :-) *) let cp src dst = if Filename.check_suffix src ".a" && Filename.check_suffix dst ".a" diff --git a/ocamlbuild/shell.mli b/ocamlbuild/shell.mli index 2d867b03..b5abd85d 100644 --- a/ocamlbuild/shell.mli +++ b/ocamlbuild/shell.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index c191cbef..bc217789 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) @@ -22,7 +23,7 @@ end module type SET = sig include Set.S - val find : (elt -> bool) -> t -> elt + val find_elt : (elt -> bool) -> t -> elt val map : (elt -> elt) -> t -> t val of_list : elt list -> t val print : Format.formatter -> t -> unit @@ -94,6 +95,12 @@ end module type TAGS = sig include Set.S with type elt = string + (** [Tags.elt] represents a tag, which is simply a string, usually + lowercase, for example "ocaml" or "native". The set of tags + attached to a file is computed by applying the tagging rules to + the filename. Tagging rules are defined in _tags files in any + parent directory of a file, up to the main project directory. *) + val of_list : string list -> t val print : Format.formatter -> t -> unit val does_match : t -> t -> bool @@ -152,8 +159,8 @@ module type PATHNAME = sig end end -(** Provides an abstract type for easily building complex shell commands without making - quotation mistakes. *) +(** Provides an abstract type for easily building complex shell + commands without making quotation mistakes. *) module type COMMAND = sig type tags type pathname @@ -161,27 +168,33 @@ module type COMMAND = sig (** The type [t] provides some basic combinators and command primitives. Other commands can be made of command specifications ([spec]). *) type t = - | Seq of t list (** A sequence of commands (like the `;' in shell) *) - | Cmd of spec (** A command is made of command specifications ([spec]) *) - | Echo of string list * pathname (** Write the given strings (w/ any formatting) to the given file *) - | Nop (** The command that does nothing *) + | Seq of t list (** A sequence of commands (like the `;' in shell) *) + | Cmd of spec (** A command is made of command specifications ([spec]) *) + | Echo of string list * pathname + (** Write the given strings (w/ any formatting) to the given file *) + | Nop (** The command that does nothing *) (** The type for command specifications. That is pieces of command. *) and spec = - | N (** No operation. *) - | S of spec list (** A sequence. This gets flattened in the last stages *) - | A of string (** An atom. *) - | P of pathname (** A pathname. *) - | Px of pathname (** A pathname, that will also be given to the call_with_target hook. *) - | Sh of string (** A bit of raw shell code, that will not be escaped. *) - | T of tags (** A set of tags, that describe properties and some semantics - information about the command, afterward these tags will be - replaced by command [spec]s (flags for instance). *) - | V of string (** A virtual command, that will be resolved at execution using [resolve_virtuals] *) - | Quote of spec (** A string that should be quoted like a filename but isn't really one. *) + | N (** No operation. *) + | S of spec list (** A sequence. This gets flattened in the last stages *) + | A of string (** An atom. *) + | P of pathname (** A pathname. *) + | Px of pathname (** A pathname, that will also be given to the + call_with_target hook. *) + | Sh of string (** A bit of raw shell code, that will not be escaped. *) + | T of tags (** A set of tags, that describe properties and + some semantics information about the + command, afterward these tags will be + replaced by command [spec]s (flags for + instance). *) + | V of string (** A virtual command, that will be resolved at + execution using [resolve_virtuals] *) + | Quote of spec (** A string that should be quoted like a + filename but isn't really one. *) (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ] - and vspec = + and vspec = [ `N | `S of vspec list | `A of string @@ -190,10 +203,10 @@ module type COMMAND = sig | `Sh of string | `Quote of vspec ] - val spec_of_vspec : vspec -> spec - val vspec_of_spec : spec -> vspec - val t_of_v : v -> t - val v_of_t : t -> v*) + val spec_of_vspec : vspec -> spec + val vspec_of_spec : spec -> vspec + val t_of_v : v -> t + val v_of_t : t -> v*) (** Will convert a string list to a list of atoms by adding [A] constructors. *) val atomize : string list -> spec @@ -347,6 +360,10 @@ module type MISC = sig val ( @:= ) : 'a list ref -> 'a list -> unit val memo : ('a -> 'b) -> ('a -> 'b) + + val memo2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c) + + val memo3 : ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd) end module type OPTIONS = sig @@ -386,6 +403,7 @@ module type OPTIONS = sig val ocaml_libs : string list ref val ocaml_mods : string list ref val ocaml_pkgs : string list ref + val ocaml_syntax : string option ref val ocaml_cflags : string list ref val ocaml_lflags : string list ref val ocaml_ppflags : string list ref @@ -502,7 +520,8 @@ include directories, libraries and special link options. *) (** Same as [link_flags_byte] but for native mode. *) end -(** This module contains the functions and values that can be used by plugins. *) +(** This module contains the functions and values that can be used by + plugins. *) module type PLUGIN = sig module Pathname : PATHNAME module Tags : TAGS @@ -516,8 +535,14 @@ module type PLUGIN = sig module Findlib : FINDLIB with type command_spec = Command.spec include MISC - (** See [COMMAND] for the description of these types. *) - type command = Command.t = Seq of command list | Cmd of spec | Echo of string list * Pathname.t | Nop + (** See {!COMMAND.t} for the description of this type. *) + type command = Command.t = + | Seq of command list + | Cmd of spec + | Echo of string list * Pathname.t + | Nop + + (** See {!COMMAND.spec} for the description of this type. *) and spec = Command.spec = | N | S of spec list | A of string | P of string | Px of string | Sh of string | T of Tags.t | V of string | Quote of spec @@ -538,8 +563,8 @@ module type PLUGIN = sig if the given option is Some. *) val ( +++ ) : Tags.t -> Tags.elt option -> Tags.t - (** [tags---optional_tag] Remove the given optional tag to the given set of tags - if the given option is Some. *) + (** [tags---optional_tag] Remove the given optional tag to the given + set of tags if the given option is Some. *) val ( --- ) : Tags.t -> Tags.elt option -> Tags.t (** The type of the builder environments. Here an environment is just the @@ -555,9 +580,10 @@ module type PLUGIN = sig type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list (** This is the type for rule actions. An action receive as argument, the - environment lookup function (see [env]), and a function to dynamically - build more targets (see [builder]). An action should return the command - to run in order to build the rule productions using the rule dependencies. *) + environment lookup function (see {!env}), and a function to dynamically + build more targets (see {!builder}). An action should return the command + to run in order to build the rule productions using the rule dependencies. + *) type action = env -> builder -> Command.t (** This is the main function for adding a rule to the ocamlbuild engine. @@ -594,12 +620,14 @@ module type PLUGIN = sig (** Empties the list of rules of the ocamlbuild engine. *) val clear_rules : unit -> unit - (** [dep tags deps] Will build [deps] when all [tags] will be activated. *) + (** [dep tags deps] Will build [deps] when all [tags] will be activated. + If you do not know which tags to use, have a look to the file + _build/_log after trying to compile your code. *) val dep : Tags.elt list -> Pathname.t list -> unit - (** [pdep tags ptag deps] is equivalent to [dep tags deps], with an additional - parameterized tag [ptag]. [deps] is now a function which takes the - parameter of the tag [ptag] as an argument. + (** [pdep tags ptag deps] is equivalent to [dep tags deps], with an + additional parameterized tag [ptag]. [deps] is now a function + which takes the parameter of the tag [ptag] as an argument. Example: [pdep ["ocaml"; "compile"] "autodep" (fun param -> param)] @@ -608,7 +636,9 @@ module type PLUGIN = sig val pdep : Tags.elt list -> Tags.elt -> (string -> Pathname.t list) -> unit (** [flag tags command_spec] Will inject the given piece of command - ([command_spec]) when all [tags] will be activated. *) + ([command_spec]) when all [tags] will be activated. + If you do not know which tags to use, have a look to the file + _build/_log after trying to compile your code. *) val flag : Tags.elt list -> Command.spec -> unit (** Allows to use [flag] with a parameterized tag (as [pdep] for [dep]). @@ -634,26 +664,30 @@ module type PLUGIN = sig (string -> Command.spec) -> unit (** [non_dependency module_path module_name] - Example: + Example: [non_dependency "foo/bar/baz" "Goo"] - Says that the module [Baz] in the file [foo/bar/baz.*] does not depend on [Goo]. *) + Says that the module [Baz] in the file [foo/bar/baz.*] does + not depend on [Goo]. *) val non_dependency : Pathname.t -> string -> unit (** [use_lib module_path lib_path]*) val use_lib : Pathname.t -> Pathname.t -> unit - (** [ocaml_lib library_pathname] - Declare an ocaml library. + (** [ocaml_lib library_pathname] Declare an ocaml library. + This informs ocamlbuild and produce tags to use the library; + they are named by default use_#{library_name}. - Example: ocaml_lib "foo/bar" - This will setup the tag use_bar tag. + Example: [ocaml_lib "foo/bar"] will setup the tag use_bar. At link time it will include: foo/bar.cma or foo/bar.cmxa - If you supply the ~dir:"boo" option -I boo - will be added at link and compile time. - Use ~extern:true for non-ocamlbuild handled libraries. - Use ~byte:false or ~native:false to disable byte or native mode. - Use ~tag_name:"usebar" to override the default tag name. *) + @param dir supply the [~dir:"boo"] option to add '-I boo' + at link and compile time. + @param extern use ~extern:true for non-ocamlbuild handled libraries. + Set this to add libraries whose sources are not in your project. + @param byte use ~byte:false to disable byte mode. + @param native use ~native:false to disable native mode. + @param tag_name Use ~tag_name:"usebar" to override the default + tag name. *) val ocaml_lib : ?extern:bool -> ?byte:bool -> @@ -664,10 +698,10 @@ module type PLUGIN = sig (** [expand_module include_dirs module_name extensions] Example: - [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] = - ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi"; - "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi"; - "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *) + [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] = + ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi"; + "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi"; + "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *) val expand_module : Pathname.t list -> Pathname.t -> string list -> Pathname.t list @@ -706,7 +740,12 @@ module type PLUGIN = sig this package even if it contains that module. *) val hide_package_contents : string -> unit - (** [tag_file filename tag_list] Tag the given filename with all given tags. *) + (** [tag_file filename tag_list] Tag the given filename with all + given tags. Prefix a tag with the minus sign to remove it. + This is usually used as an [After_rules] hook. + For example [tag_file "bla.ml" ["use_unix"]] tags the file + "bla.ml" with "use_unix" and [tag_file "bla.ml" ["-use_unix"]] + removes the tag "use_unix" from the file "bla.ml". *) val tag_file : Pathname.t -> Tags.elt list -> unit (** [tag_any tag_list] Tag anything with all given tags. *) diff --git a/ocamlbuild/slurp.ml b/ocamlbuild/slurp.ml index e807ff7f..d6c2846a 100644 --- a/ocamlbuild/slurp.ml +++ b/ocamlbuild/slurp.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/slurp.mli b/ocamlbuild/slurp.mli index a3a141d8..45d34fc7 100644 --- a/ocamlbuild/slurp.mli +++ b/ocamlbuild/slurp.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/solver.ml b/ocamlbuild/solver.ml index 94b3d930..aaaa36b0 100644 --- a/ocamlbuild/solver.ml +++ b/ocamlbuild/solver.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/solver.mli b/ocamlbuild/solver.mli index b2ec4952..5f47a652 100644 --- a/ocamlbuild/solver.mli +++ b/ocamlbuild/solver.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh index 7386cbd3..1d1fa3ce 100755 --- a/ocamlbuild/start.sh +++ b/ocamlbuild/start.sh @@ -28,7 +28,6 @@ let o = "o";; let so = "so";; let exe = "";; EOF -ocamlc -c std_signatures.mli ocamlc -c signatures.mli ocamlc -c tags.mli ocamlc -c ocamlbuild_Myocamlbuild_config.ml diff --git a/ocamlbuild/tags.ml b/ocamlbuild/tags.ml index 811657ac..7f103b79 100644 --- a/ocamlbuild/tags.ml +++ b/ocamlbuild/tags.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/tags.mli b/ocamlbuild/tags.mli index dadf9afa..1fd1285b 100644 --- a/ocamlbuild/tags.mli +++ b/ocamlbuild/tags.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/testsuite/level0.ml b/ocamlbuild/testsuite/level0.ml new file mode 100644 index 00000000..aaa08c26 --- /dev/null +++ b/ocamlbuild/testsuite/level0.ml @@ -0,0 +1,230 @@ +#load "unix.cma";; + +let ocamlbuild = try Sys.getenv "OCAMLBUILD" with Not_found -> "ocamlbuild";; + +#use "ocamlbuild_test.ml";; + +module M = Match;; +module T = Tree;; + +let _build = M.d "_build";; + +test "BasicNativeTree" + ~description:"Output tree for native compilation" + ~tree:[T.f "dummy.ml"] + ~matching:[M.Exact + (_build + (M.lf + ["_digests"; + "dummy.cmi"; + "dummy.cmo"; + "dummy.cmx"; + "dummy.ml"; + "dummy.ml.depends"; + "dummy.native"; + "dummy.o"; + "_log"]))] + ~targets:("dummy.native",[]) ();; + +test "BasicByteTree" + ~description:"Output tree for byte compilation" + ~tree:[T.f "dummy.ml"] + ~matching:[M.Exact + (_build + (M.lf + ["_digests"; + "dummy.cmi"; + "dummy.cmo"; + "dummy.ml"; + "dummy.ml.depends"; + "dummy.byte"; + "_log"]))] + ~targets:("dummy.byte",[]) ();; + +test "SeveralTargets" + ~description:"Several targets" + ~tree:[T.f "dummy.ml"] + ~matching:[_build (M.lf ["dummy.byte"; "dummy.native"])] + ~targets:("dummy.byte",["dummy.native"]) ();; + +let alt_build_dir = "BuIlD2";; + +test "BuildDir" + ~options:[`build_dir alt_build_dir] + ~description:"Different build directory" + ~tree:[T.f "dummy.ml"] + ~matching:[M.d alt_build_dir (M.lf ["dummy.byte"])] + ~targets:("dummy.byte",[]) ();; + +test "camlp4.opt" + ~description:"Fixes PR#5652" + ~options:[`use_ocamlfind; `package "camlp4.macro";`tags ["camlp4o.opt"; "syntax\\(camp4o\\)"]; + `ppflag "camlp4o.opt"; `ppflag "-parser"; `ppflag "macro"; `ppflag "-DTEST"] + ~tree:[T.f "dummy.ml" ~content:"IFDEF TEST THEN\nprint_endline \"Hello\";;\nENDIF;;"] + ~matching:[M.x "dummy.native" ~output:"Hello"] + ~targets:("dummy.native",[]) ();; + +test "ThreadAndArchive" + ~description:"Fixes PR#6058" + ~options:[`use_ocamlfind; `package "threads"; `tag "thread"] + ~tree:[T.f "t.ml" ~content:""] + ~matching:[M.f "_build/t.cma"] + ~targets:("t.cma",[]) ();; + +let tag_pat_msgs = + ["*:a", "File \"_tags\", line 1, column 0: Lexing error: Invalid globbing pattern \"*\"."; + "\n<*{>:a", "File \"_tags\", line 2, column 0: Lexing error: Invalid globbing pattern \"<*{>\"."; + "<*>: ~@a,# ~a", "File \"_tags\", line 1, column 10: Lexing error: Only ',' separated tags are alllowed."];; + +List.iteri (fun i (content,failing_msg) -> + test (Printf.sprintf "TagsErrorMessage_%d" (i+1)) + ~description:"Confirm relevance of an error message due to erronous _tags" + ~failing_msg + ~tree:[T.f "_tags" ~content; T.f "dummy.ml"] + ~targets:("dummy.native",[]) ()) tag_pat_msgs;; + +test "SubtoolOptions" + ~description:"Options that come from tags that needs to be spliced to the subtool invocation (PR#5763)" + ~options:[`use_menhir; `use_ocamlfind; `tags["package\\(camlp4.fulllib\\)"]] + ~tree:[T.f "parser.mly" ~content:"%{\n%}\n%token DUMMY\n%start test%%test: {None}\n\n"] + ~matching:[M.f "parser.native"; M.f "parser.byte"] + ~targets:("parser.native",["parser.byte"]) + ();; + +test "Itarget" + ~description:".itarget building with dependencies between the modules (PR#5686)" + ~tree:[T.f "foo.itarget" ~content:"a.cma\nb.byte\n"; T.f "a.ml"; T.f "b.ml" ~content:"open A\n"] + ~matching:[M.f "a.cma"; M.f "b.byte"] + ~targets:("foo.otarget",[]) ();; + +test "PackAcross" + ~description:"Pack using a module from the other tree (PR#4592)" + ~tree:[T.f "main.ml" ~content:"let _ = Pack.Packed.g ()\n"; + T.f "Pack.mlpack" ~content:"pack/Packed"; + T.f "_tags" ~content:": include\n: for-pack(Pack)\n"; + T.d "lib" [T.f "Lib.ml" ~content:"let f()=()"; + T.f "Lib.mli" ~content:"val f : unit -> unit"]; + T.d "pack" [T.f "Packed.ml" ~content:"let g() = Lib.f ()"]] + ~matching:[M.f "main.byte"; M.f "main.native"] + ~targets:("main.byte", ["main.native"]) + ();; + +test "PackAcross2" + ~description:"Pack using a module from the other tree (PR#4592)" + ~tree:[T.f "a2.mli" ~content:"val f : unit -> unit"; + T.f "a2.ml" ~content:"let f _ = ()"; + T.f "lib.ml" ~content:"module A = A2"; + T.f "b.ml" ~content:"let g = Lib.A.f"; + T.f "sup.mlpack" ~content:"B"; + T.f "prog.ml" ~content:"Sup.B.g"] + ~matching:[M.f "prog.byte"] + ~targets:("prog.byte",[]) ();; + +test "PackAcross3" + ~description:"Pack using a module from the other tree (PR#4592)" + ~tree:[T.d "foo" [ T.f "bar.ml" ~content:"let baz = Quux.xyzzy"]; + T.f "foo.mlpack" ~content:"foo/Bar"; + T.f "main.ml" ~content:"prerr_endline Foo.Bar.baz"; + T.f "myocamlbuild.ml"; + T.f "quux.ml" ~content:"let xyzzy = \"xyzzy\""; + T.f "quux.mli" ~content:"val xyzzy : string"] + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +test "SyntaxFlag" + ~description:"-syntax for ocamlbuild" + ~options:[`use_ocamlfind; `package "camlp4.macro"; `syntax "camlp4o"] + ~tree:[T.f "dummy.ml" ~content:"IFDEF TEST THEN\nprint_endline \"Hello\";;\nENDIF;;"] + ~matching:[M.f "dummy.native"] + ~targets:("dummy.native",[]) ();; + +test "NoIncludeNoHygiene1" + ~description:"check that hygiene checks are only done in traversed directories\ + (PR#4502)" + ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"]; + T.f "hello.ml" ~content:"print_endline \"Hello, World!\""; + T.f "_tags" ~content:": -traverse"] + ~pre_cmd:"ocamlc -c must_ignore/dirty.mli" + (* will make hygiene fail if must_ignore/ is checked *) + ~targets:("hello.byte",[]) ();; + +test "NoIncludeNoHygiene2" + ~description:"check that hygiene checks are not done on the -build-dir \ + (PR#4502)" + ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"]; + T.f "hello.ml" ~content:"print_endline \"Hello, World!\""; + T.f "_tags" ~content:""] + ~options:[`build_dir "must_ignore"] + ~pre_cmd:"ocamlc -c must_ignore/dirty.mli" + (* will make hygiene fail if must_ignore/ is checked *) + ~targets:("hello.byte",[]) ();; + +test "NoIncludeNoHygiene3" + ~description:"check that hygiene checks are not done on excluded dirs (PR#4502)" + ~tree:[T.d "must_ignore" [ T.f "dirty.mli" ~content:"val bug : int"]; + T.f "hello.ml" ~content:"print_endline \"Hello, World!\""; + T.f "_tags" ~content:""] + ~options:[`X "must_ignore"] + ~pre_cmd:"ocamlc -c must_ignore/dirty.mli" + (* will make hygiene fail if must_ignore/ is checked *) + ~targets:("hello.byte",[]) ();; + +test "OutputObj" + ~description:"output_obj targets for native and bytecode (PR #6049)" + ~tree:[T.f "hello.ml" ~content:"print_endline \"Hello, World!\""] + ~targets:("hello.byte.o",["hello.byte.c";"hello.native.o"]) ();; + +test "StrictSequenceFlag" + ~description:"-strict_sequence tag" + ~tree:[T.f "hello.ml" ~content:"let () = 1; ()"; + T.f "_tags" ~content:"true: strict_sequence\n"] + ~options:[`quiet] + ~failing_msg:"File \"hello.ml\", line 1, characters 9-10: +Error: This expression has type int but an expression was expected of type + unit\nCommand exited with code 2." + ~targets:("hello.byte",[]) ();; + +test "PrincipalFlag" + ~description:"-principal tag" + ~tree:[T.f "hello.ml" ~content:"type s={foo:int;bar:unit} type t={foo:int} let f x = x.bar;x.foo"; + T.f "_tags" ~content:"true: principal\n"] + ~options:[`quiet] + ~failing_msg:"File \"hello.ml\", line 1, characters 61-64: +Warning 18: this type-based field disambiguation is not principal." + ~targets:("hello.byte",[]) ();; + +test "ModularPlugin1" + ~options:[`quiet; `plugin_tag "use_str"] + ~description:"test a plugin with dependency on external libraries" + ~tree:[T.f "main.ml" ~content:"let x = 1"; + T.f "myocamlbuild.ml" ~content:"ignore (Str.quote \"\");;"] + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +test "ModularPlugin2" + ~description:"check that parametrized tags defined by the plugin + do not warn at plugin-compilation time" + ~options:[`quiet] + ~tree:[T.f "main.ml" ~content:"let x = 1"; + T.f "_tags" ~content:": toto(-g)"; + T.f "myocamlbuild.ml" + ~content:"open Ocamlbuild_plugin;; + pflag [\"link\"] \"toto\" (fun arg -> A arg);;"] + ~failing_msg:"" + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +test "ModularPlugin3" + ~description:"check that unknown parametrized tags encountered + during plugin compilation still warn" + ~options:[`quiet; `plugin_tag "'toto(-g)'"] + ~tree:[T.f "main.ml" ~content:"let x = 1"; + T.f "myocamlbuild.ml" + ~content:"open Ocamlbuild_plugin;; + pflag [\"link\"] \"toto\" (fun arg -> A arg);;"] + ~failing_msg:"Warning: tag \"toto\" does not expect a parameter, \ + but is used with parameter \"-g\"" + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +run ~root:"_test";; diff --git a/ocamlbuild/testsuite/ocamlbuild_test.ml b/ocamlbuild/testsuite/ocamlbuild_test.ml new file mode 100644 index 00000000..3ba353eb --- /dev/null +++ b/ocamlbuild/testsuite/ocamlbuild_test.ml @@ -0,0 +1,471 @@ +(***********************************************************************) +(* *) +(* ocamlbuild *) +(* *) +(* Wojciech Meyer *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Format + +external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" + +let print_list ~sep f ppf = function +| [] -> () +| x :: [] -> f ppf x +| x :: xs -> f ppf x; List.iter (fun x -> sep ppf (); f ppf x) xs + +let print_list_com f = print_list ~sep:(fun ppf () -> pp_print_string ppf ",") f +let print_list_blank f = print_list ~sep:(fun ppf () -> pp_print_string ppf " ") f +let print_string_list = print_list_com pp_print_string +let print_string_list_com = print_list_com pp_print_string +let print_string_list_blank = print_list_blank pp_print_string + +let exists filename = + try ignore(Unix.stat filename); true + with Unix.Unix_error ((Unix.ENOENT),_,_) -> false + +let execute cmd = + let ic = Unix.open_process_in cmd and lst = ref [] in + try while true do lst := input_line ic :: !lst done; assert false + with End_of_file -> + let ret_code = Unix.close_process_in ic + in ret_code, List.rev !lst + +let rm f = + if exists f then + ignore(Sys.command (Printf.sprintf "rm -r %s" f)) + +module Match = struct + + type atts = unit + + (* File consists of file attribute and name *) + type file = atts * string + + (* Result is an outcome of execution, if consists of returned exit code, + and stream from stdout *) + type result = int * string + + type t = + (* Represents file in the tree *) + | F of file + (* Directory, consists of name and sub entries *) + | D of file * t list + (* Like file, but will be executed, and the result will compared *) + | X of file * result + (* Symlink *) + | L of file * file + (* We request that everything below should match exactly *) + | Exact of t + (* Here we want just the tree contained entities but we allow some + other stuff to be there too *) + | Contains of t + (* Any means that we match anything *) + | Any + (* Empty a tree leaf that don't match at all *) + | Empty + + (* Type of error, we either expect something or something is un-expected *) + type error = + Expected of string + | Unexpected of string + | Structure of string * string list + | Output of string * string + + (* This will print the tree *) + let print ppf tree = + let rec lines ppf lst = + List.iter (fun line -> pp_print_space ppf (); item ppf line) lst + and item ppf = function + | F (_, name) -> fprintf ppf "@[%s@]" name + | D ((_, name), children) -> fprintf ppf "@[@[%s/@]%a@]" name lines children + | X ((_,name), _) -> fprintf ppf "@[%s@]" name + | L ((_,src), (_,dst)) -> fprintf ppf "@[%s->%s@]@" src dst + | Exact content -> fprintf ppf "{%a}" item content + | Contains content -> fprintf ppf "<%a>" item content + | Any -> pp_print_char ppf '*' + | Empty -> pp_print_char ppf '#' + in + pp_open_vbox ppf 0; + item ppf tree; + pp_close_box ppf () + + let f ?(atts=()) name = F (atts, name) + let d ?(atts=()) name children = D ((atts, name), children) + let lf ?(atts=()) lst = List.map (fun nm -> F (atts,nm)) lst + let x ?(atts=()) name ~output = X ((atts,name), (0,output)) + + let match_with_fs ~root m = + + let errors = ref [] in + + let rec visit ~exact path m = + let file name = + "./" ^ (List.rev (name :: path) |> String.concat "/") + + in + + let exists_assert filename = + if not (exists (file filename)) then + errors := Expected filename :: !errors; + in + + let take_name = function + | F (_, name) + | D ((_, name),_) -> [name] + | _ -> [] + in + + match m with + | F ((),name) -> + exists_assert name + | D (((),name), sub) -> + exists_assert name; + let lst = List.flatten (List.map take_name sub) in + let lst' = Sys.readdir name |> Array.to_list in + let lst' = List.filter (fun x -> not (List.mem x lst)) lst' in + (if exact && lst' <> [] then + errors := Structure ((file name), lst') :: !errors); + List.iter (visit ~exact (name :: path)) sub + | X (((), name), (retcode, output)) -> + let _,output' = execute (file name) in + let output' = String.concat "\n" output' in + if output <> output' then + errors := Output (output, output') :: !errors + | Exact sub -> visit ~exact:true path sub + | Contains sub -> visit ~exact:false path sub + | _ -> assert false + in + let dir = Sys.getcwd () in + Unix.chdir root; + visit ~exact:false [] m; + Unix.chdir dir; + List.rev !errors + + let string_of_error = function + | Expected s -> Printf.sprintf "expected '%s' on a file system" s + | Unexpected s -> Printf.sprintf "un-expected '%s' on a file system" s + | Structure (s,l) -> Printf.sprintf "directory structure '%s' has un-expected files %s" s (String.concat ", " l) + | Output (e, p) -> Printf.sprintf "not matching output '%s' expected but got %s" e p +end + +module Option = struct + + type flag = string + type path = string + type level = int + type package = string + type file = string + type command = string + type _module = string + type tag = string + + type t = + [ `version + | `vnum + | `quiet + | `verbose of level + | `documentation + | `log of file + | `no_log + | `clean + | `r + | `I of path + | `Is of path list + | `X of path + | `Xs of path list + | `lib of flag + | `libs of flag list + | `_mod of _module + | `mods of _module list + | `pkg of package + | `pkgs of package list + | `package of package + | `syntax of string + | `lflag of flag + | `lflags of flag list + | `cflag of flag + | `cflags of flag list + | `docflag of flag + | `docflags of flag list + | `yaccflag of flag + | `yaccflags of flag list + | `lexflag of flag + | `lexflags of flag list + | `ppflag of flag + | `pp of flag list + | `tag of tag + | `tags of tag list + | `plugin_tag of tag + | `plugin_tags of tag list + | `tag_line of tag + | `show_tags of path + | `ignore of _module list + | `no_links + | `no_skip + | `no_hygiene + | `no_plugin + | `no_stdlib + | `dont_catch_errors + | `just_plugin + | `byte_plugin + | `plugin_option + | `sanitization_script + | `no_sanitize + | `nothing_should_be_rebuilt + | `classic_display + | `use_menhir + | `use_jocaml + | `use_ocamlfind + | `j of level + | `build_dir of path + | `install_lib_dir of path + | `install_bin_dir of path + | `where + | `ocamlc of command + | `ocamlopt of command + | `ocamldep of command + | `ocamldoc of command + | `ocamlyacc of command + | `menhir of command + | `ocamllex of command + | `ocamlmktop of command + | `ocamlrun of command + | `help ] + + type arg = string * string list + + let print_level = pp_print_int + let print_flag = pp_print_string + let print_package = pp_print_string + let print_tag = pp_print_string + let print_tags = print_string_list_com + let print_path = pp_print_string + let print_paths = print_string_list_com + let print_flags = print_string_list_com + let print_module = pp_print_string + let print_modules = print_string_list_com + let print_packages = print_string_list_com + let print_command = pp_print_string + + let print_opt ppf o = + fprintf ppf "-"; + match o with + | `version -> fprintf ppf "version" + | `vnum -> fprintf ppf "vnum" + | `quiet -> fprintf ppf "quiet" + | `verbose level -> fprintf ppf "verbose %a" print_level level + | `documentation -> fprintf ppf "documentation" + | `log file -> fprintf ppf "log" + | `no_log -> fprintf ppf "no-log" + | `clean -> fprintf ppf "clean" + | `r -> fprintf ppf "r" + | `I path -> fprintf ppf "I %a" print_path path + | `Is paths -> fprintf ppf "Is %a" print_paths paths + | `X path -> fprintf ppf "X %a" print_path path + | `Xs paths -> fprintf ppf "Xs %a" print_paths paths + | `lib flag -> fprintf ppf "lib %a" print_flag flag + | `libs flags -> fprintf ppf "libs %a" print_flags flags + | `_mod _module -> fprintf ppf "mod %a" print_module _module + | `mods _modules -> fprintf ppf "mods %a" print_modules _modules + | `pkg package -> fprintf ppf "pkg %a" print_package package + | `pkgs packages -> fprintf ppf "pkgs %a" print_packages packages + | `package package -> fprintf ppf "package %a" print_package package + | `syntax syntax -> fprintf ppf "syntax %a" pp_print_string syntax + | `lflag flag -> fprintf ppf "lflag %a" print_flag flag + | `lflags flags -> fprintf ppf "lflags %a" print_flags flags + | `cflag flag -> fprintf ppf "cflag %a" print_flag flag + | `cflags flags -> fprintf ppf "cflags %a" print_flags flags + | `docflag flag -> fprintf ppf "docflag %a" print_flag flag + | `docflags flags -> fprintf ppf "docflags %a" print_flags flags + | `yaccflag flag -> fprintf ppf "yaccflag %a" print_flag flag + | `yaccflags flags -> fprintf ppf "yaccflags %a" print_flags flags + | `lexflag flag -> fprintf ppf "lexflag %a" print_flag flag + | `lexflags flags -> fprintf ppf "lexflags %a" print_flags flags + | `ppflag flag -> fprintf ppf "ppflag %a" print_flag flag + | `pp flags -> fprintf ppf "pp %a" print_flags flags + | `tag tag -> fprintf ppf "tag %a" print_tag tag + | `tags tags -> fprintf ppf "tags %a" print_tags tags + | `plugin_tag tag -> fprintf ppf "plugin-tag %a" print_tag tag + | `plugin_tags tags -> fprintf ppf "plugin-tags %a" print_tags tags + | `tag_line tag -> fprintf ppf "tag-line %a" print_tag tag + | `show_tags path -> fprintf ppf "show-tags %a" print_path path + | `ignore _modules -> fprintf ppf "ignore %a" print_modules _modules + | `no_links -> fprintf ppf "no-links" + | `no_skip -> fprintf ppf "no-skip" + | `no_hygiene -> fprintf ppf "no-hygiene" + | `no_plugin -> fprintf ppf "no-pluging" + | `no_stdlib -> fprintf ppf "no-stdlib" + | `dont_catch_errors -> fprintf ppf "dont" + | `just_plugin -> fprintf ppf "just-plugin" + | `byte_plugin -> fprintf ppf "byte-plugin" + | `plugin_option -> fprintf ppf "plugin-option" + | `sanitization_script -> fprintf ppf "sanitization-script" + | `no_sanitize -> fprintf ppf "no-sanitze" + | `nothing_should_be_rebuilt -> fprintf ppf "nothing_should_be_rebuilt" + | `classic_display -> fprintf ppf "classic-display" + | `use_menhir -> fprintf ppf "use-menhir" + | `use_jocaml -> fprintf ppf "use-jocaml" + | `use_ocamlfind -> fprintf ppf "use-ocamlfind" + | `j level -> fprintf ppf "j %a" print_level level + | `build_dir path -> fprintf ppf "build-dir %a" print_path path + | `install_lib_dir path -> fprintf ppf "install %a" print_path path + | `install_bin_dir path -> fprintf ppf "install %a" print_path path + | `where -> fprintf ppf "where" + | `ocamlc command -> fprintf ppf "ocamlc %a" print_command command + | `ocamlopt command -> fprintf ppf "ocamlopt %a" print_command command + | `ocamldep command -> fprintf ppf "ocamldep %a" print_command command + | `ocamldoc command -> fprintf ppf "ocamldoc %a" print_command command + | `ocamlyacc command -> fprintf ppf "ocamlyacc %a" print_command command + | `menhir command -> fprintf ppf "menhir %a" print_command command + | `ocamllex command -> fprintf ppf "ocamllex %a" print_command command + | `ocamlmktop command -> fprintf ppf "ocamlmktop %a" print_command command + | `ocamlrun command -> fprintf ppf "ocamlrun %a" print_command command + | `help -> fprintf ppf "help" + +end + +module Tree = struct + + type name = string + type content = string + + type t = + F of name * content + | D of name * t list + | E + + let f ?(content="") name = F (name, content) + let d name children = D (name, children) + + let create_on_fs ~root f = + + let rec visit path f = + let file name = + List.rev (name :: path) + |> String.concat "/" + in + match f with + | F (name, content) -> + let ch = file name |> open_out in + output_string ch content; + close_out ch + | D (name, sub) -> + (* print_endline ("mking " ^ (file name)); *) + Unix.mkdir (file name) 0o750; + List.iter (visit (name :: path)) sub + | E -> () + in + + let dir = Sys.getcwd () in + Unix.chdir root; + visit [] f; + Unix.chdir dir + +end + +type content = string +type filename = string +type run = filename * content + +type test = { name : string + ; description : string + ; tree : Tree.t list + ; matching : Match.t list + ; options : Option.t list + ; targets : string * string list + ; pre_cmd : string option + ; failing_msg : string option + ; run : run list } + +let tests = ref [] + +let test name + ~description + ?(options=[]) ?(run=[]) ?pre_cmd ?failing_msg + ?(tree=[]) + ?(matching=[]) + ~targets () + = + tests := !tests @ [{ name; description; tree; matching; options; targets; pre_cmd; failing_msg; run }] + +let run ~root = + let dir = Sys.getcwd () in + let root = dir ^ "/" ^ root in + rm root; + Unix.mkdir root 0o750; + + let command opts args = + let b = Buffer.create 127 in + let f = Format.formatter_of_buffer b in + fprintf f "%s %a %a" ocamlbuild (print_list_blank Option.print_opt) opts (print_list_blank pp_print_string) args; + Format.pp_print_flush f (); + Buffer.contents b + in + + let one_test + { name + ; description + ; tree + ; matching + ; options + ; targets + ; failing_msg + ; pre_cmd + ; run } = + + let full_name = root ^ "/" ^ name in + rm full_name; + Unix.mkdir full_name 0o750; + List.iter (Tree.create_on_fs ~root:full_name) tree; + Unix.chdir full_name; + + (match pre_cmd with + | None -> () + | Some str -> ignore(Sys.command str)); + + let log_name = full_name ^ ".log" in + + let cmd = command options (fst targets :: snd targets) in + let allow_failure = failing_msg <> None in + + Unix.(match execute cmd with + | WEXITED n,lines + | WSIGNALED n,lines + | WSTOPPED n,lines when allow_failure || n <> 0 -> + begin match failing_msg with + | None -> + let ch = open_out log_name in + List.iter (fun l -> output_string ch l; output_string ch "\n") lines; + close_out ch; + Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name + (Printf.sprintf "Command '%s' with error code %n output written to %s" cmd n log_name); + | Some failing_msg -> + let starts_with_plus s = String.length s > 0 && s.[0] = '+' in + let lines = List.filter (fun s -> not (starts_with_plus s)) lines in + let msg = String.concat "\n" lines in + if failing_msg = msg then + Printf.printf "\x1b[0;32m\x1b[1m[PASSED]\x1b[0m \x1b[1m%-20s\x1b[0;36m%s.\n\x1b[m%!" name description + else + Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name ((Printf.sprintf "Failure with not matching message:\n%s\n!=\n%s\n") msg failing_msg) + end; + | _ -> + let errors = List.concat (List.map (Match.match_with_fs ~root:full_name) matching) in + begin if errors == [] then + Printf.printf "\x1b[0;32m\x1b[1m[PASSED]\x1b[0m \x1b[1m%-20s\x1b[0;36m%s.\n\x1b[m%!" name description + else begin + let ch = open_out log_name in + output_string ch ("Run '" ^ cmd ^ "'\n"); + List.iter (fun e -> output_string ch (Match.string_of_error e); output_string ch ".\n") errors; + close_out ch; + Printf.printf "\x1b[0;31m\x1b[1m[FAILED]\x1b[0m \x1b[1m%-20s\x1b[0;33m%s.\n\x1b[m%!" name + (Printf.sprintf "Some system checks failed, output written to %s" log_name) + end + end) + + in List.iter one_test !tests diff --git a/ocamlbuild/tools.ml b/ocamlbuild/tools.ml index d72278e7..ce28c970 100644 --- a/ocamlbuild/tools.ml +++ b/ocamlbuild/tools.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamlbuild/tools.mli b/ocamlbuild/tools.mli index 974ff1ad..9c2763f9 100644 --- a/ocamlbuild/tools.mli +++ b/ocamlbuild/tools.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamldoc/.depend b/ocamldoc/.depend index f8e0d357..61c131a6 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -10,26 +10,26 @@ odoc_analyse.cmo : ../utils/warnings.cmi ../typing/typetexp.cmi \ ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ - ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \ - odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ + ../parsing/syntaxerr.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/location.cmi ../parsing/lexer.cmi \ ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ ../utils/config.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \ - ../utils/ccomp.cmi odoc_analyse.cmi + odoc_analyse.cmi odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \ ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \ ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \ - ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \ - odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.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/location.cmx ../parsing/lexer.cmx \ ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ ../utils/config.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ - ../utils/ccomp.cmx odoc_analyse.cmi + odoc_analyse.cmi odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \ odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 74c82d3f..144b95d1 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -1,4 +1,5 @@ #(***********************************************************************) +#(* *) #(* OCamldoc *) #(* *) #(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ #(* *) #(***********************************************************************) -# $Id: Makefile 12707 2012-07-13 11:23:13Z doligez $ - include ../config/Makefile # Various commands and dir @@ -36,7 +35,7 @@ OCAMLDOC_OPT=$(OCAMLDOC).opt OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa -OCAMLDOC_LIBA=odoc_info.a +OCAMLDOC_LIBA=odoc_info.$(A) INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom INSTALL_BINDIR=$(OCAMLBIN) @@ -50,9 +49,9 @@ ODOC_TEST=odoc_test.cmo GENERATORS_CMOS= \ generators/odoc_todo.cmo \ generators/odoc_literate.cmo -GENERATORS_CMXS_TMP1=$(GENERATORS_CMOS:.cmo=.cmxs) -GENERATORS_CMXS_TMP2=$(NATDYNLINK:false=) -GENERATORS_CMXS=$(GENERATORS_CMXS_TMP2:true=$(GENERATORS_CMXS_TMP1)) +true = $(GENERATORS_CMOS:.cmo=.cmxs) +false = +GENERATORS_CMXS := $($(NATDYNLINK)) # Compilation @@ -128,7 +127,7 @@ EXECMOFILES=$(CMOFILES) \ odoc_texi.cmo \ odoc_dot.cmo \ odoc_gen.cmo \ - odoc_args.cmo\ + odoc_args.cmo \ odoc.cmo EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) @@ -171,6 +170,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/typedtree.cmo \ $(OCAMLSRCDIR)/typing/parmatch.cmo \ $(OCAMLSRCDIR)/typing/stypes.cmo \ + $(OCAMLSRCDIR)/typing/typedtreeMap.cmo \ $(OCAMLSRCDIR)/typing/cmt_format.cmo \ $(OCAMLSRCDIR)/typing/typecore.cmo \ $(OCAMLSRCDIR)/typing/includeclass.cmo \ @@ -187,7 +187,8 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/bytecomp/translobj.cmo \ $(OCAMLSRCDIR)/bytecomp/translcore.cmo \ $(OCAMLSRCDIR)/bytecomp/translclass.cmo \ - $(OCAMLSRCDIR)/tools/depend.cmo + $(OCAMLSRCDIR)/tools/depend.cmo \ + $(OCAMLSRCDIR)/driver/pparse.cmo OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) @@ -360,12 +361,12 @@ autotest_stdlib: dummy clean:: dummy @rm -f *~ \#*\# - @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o + @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli @rm -rf stdlib_man - @rm -f generators/*.cm[aiox] generators/*.[ao] generators/*.cmx[as] + @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as] depend:: $(OCAMLYACC) odoc_text_parser.mly diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index ad44bf8f..6b9818a9 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -1,4 +1,5 @@ #(***********************************************************************) +#(* *) #(* OCamldoc *) #(* *) #(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,16 +10,16 @@ #(* *) #(***********************************************************************) -# $Id: Makefile.nt 12692 2012-07-10 15:20:34Z doligez $ - include ../config/Makefile -CAMLRUN =../boot/ocamlrun +# Various commands and dir +########################## +CAMLRUN=../boot/ocamlrun OCAMLC = ../ocamlcomp.sh OCAMLOPT = ../ocamlcompopt.sh -OCAMLLEX =$(CAMLRUN) ../boot/ocamllex -OCAMLYACC=../boot/ocamlyacc - +OCAMLDEP = $(CAMLRUN) ../tools/ocamldep +OCAMLLEX = $(CAMLRUN) ../boot/ocamllex +OCAMLYACC= ../boot/ocamlyacc OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -62,7 +63,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) +COMPFLAGS=$(INCLUDES) -warn-error A LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -104,18 +105,18 @@ CMOFILES= odoc_config.cmo \ CMXFILES= $(CMOFILES:.cmo=.cmx) CMIFILES= $(CMOFILES:.cmo=.cmi) -EXECMOFILES=$(CMOFILES)\ - odoc_dag2html.cmo\ - odoc_to_text.cmo\ - odoc_ocamlhtml.cmo\ - odoc_html.cmo\ - odoc_man.cmo\ +EXECMOFILES=$(CMOFILES) \ + odoc_dag2html.cmo \ + odoc_to_text.cmo \ + odoc_ocamlhtml.cmo \ + odoc_html.cmo \ + odoc_man.cmo \ odoc_latex_style.cmo \ - odoc_latex.cmo\ - odoc_texi.cmo\ - odoc_dot.cmo\ - odoc_gen.cmo\ - odoc_args.cmo\ + odoc_latex.cmo \ + odoc_texi.cmo \ + odoc_dot.cmo \ + odoc_gen.cmo \ + odoc_args.cmo \ odoc.cmo @@ -159,6 +160,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/typing/typedtree.cmo \ $(OCAMLSRCDIR)/typing/parmatch.cmo \ $(OCAMLSRCDIR)/typing/stypes.cmo \ + $(OCAMLSRCDIR)/typing/typedtreeMap.cmo \ $(OCAMLSRCDIR)/typing/cmt_format.cmo \ $(OCAMLSRCDIR)/typing/typecore.cmo \ $(OCAMLSRCDIR)/typing/includeclass.cmo \ @@ -175,7 +177,8 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \ $(OCAMLSRCDIR)/bytecomp/translobj.cmo \ $(OCAMLSRCDIR)/bytecomp/translcore.cmo \ $(OCAMLSRCDIR)/bytecomp/translclass.cmo \ - $(OCAMLSRCDIR)/tools/depend.cmo + $(OCAMLSRCDIR)/tools/depend.cmo \ + $(OCAMLSRCDIR)/driver/pparse.cmo OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) @@ -199,44 +202,55 @@ $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) +# Parsers and lexers dependencies : +################################### +odoc_text_parser.ml: odoc_text_parser.mly +odoc_text_parser.mli: odoc_text_parser.mly + +odoc_parser.ml: odoc_parser.mly +odoc_parser.mli:odoc_parser.mly + +odoc_text_lexer.ml: odoc_text_lexer.mll + +odoc_lexer.ml:odoc_lexer.mll + +odoc_ocamlhtml.ml: odoc_ocamlhtml.mll + +odoc_see_lexer.ml: odoc_see_lexer.mll + + # generic rules : ################# -.SUFFIXES: .mli .ml .cmi .cmo .cmx +.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs -.mli.cmi: +.ml.cmo: $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< -.ml.cmo: +.mli.cmi: $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< -odoc_text_parser.ml odoc_text_parser.mli: odoc_text_parser.mly - $(OCAMLYACC) odoc_text_parser.mly +.ml.cmxs: + $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $< -odoc_parser.ml odoc_parser.mli: odoc_parser.mly - $(OCAMLYACC) odoc_parser.mly +.mll.ml: + $(OCAMLLEX) $< -odoc_text_lexer.ml: odoc_text_lexer.mll - $(OCAMLLEX) odoc_text_lexer.mll +.mly.ml: + $(OCAMLYACC) -v $< -odoc_lexer.ml: odoc_lexer.mll - $(OCAMLLEX) odoc_lexer.mll - -odoc_ocamlhtml.ml: odoc_ocamlhtml.mll - $(OCAMLLEX) odoc_ocamlhtml.mll - -odoc_see_lexer.ml: odoc_see_lexer.mll - $(OCAMLLEX) odoc_see_lexer.mll +.mly.mli: + $(OCAMLYACC) -v $< # Installation targets ###################### install: dummy $(MKDIR) -p $(INSTALL_BINDIR) $(MKDIR) -p $(INSTALL_LIBDIR) - $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC).exe + $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE) $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) @@ -246,7 +260,7 @@ installopt: installopt_really: $(MKDIR) -p $(INSTALL_BINDIR) $(MKDIR) -p $(INSTALL_LIBDIR) - $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT).exe + $(CP) $(OCAMLDOC_OPT) $(INSTALL_BINDIR)/$(OCAMLDOC_OPT)$(EXE) $(CP) ocamldoc.hva $(OCAMLDOC_LIBA) $(OCAMLDOC_LIBCMXA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) @@ -260,13 +274,16 @@ clean:: dummy @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli + @rm -rf stdlib_man + @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as] depend:: - rm -f .depend $(OCAMLYACC) odoc_text_parser.mly $(OCAMLYACC) odoc_parser.mly $(OCAMLLEX) odoc_text_lexer.mll $(OCAMLLEX) odoc_lexer.mll + $(OCAMLLEX) odoc_ocamlhtml.mll + $(OCAMLLEX) odoc_see_lexer.mll $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend dummy: diff --git a/ocamldoc/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml index 6a1e0783..fe993f8c 100644 --- a/ocamldoc/generators/odoc_literate.ml +++ b/ocamldoc/generators/odoc_literate.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - open Odoc_info module Naming = Odoc_html.Naming open Odoc_info.Value diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml index 626236cf..31545fee 100644 --- a/ocamldoc/generators/odoc_todo.ml +++ b/ocamldoc/generators/odoc_todo.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (** An OCamldoc generator to retrieve information in "todo" tags and generate an html page with all todo items. *) diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva index 1d0eb60d..1fb271ad 100644 --- a/ocamldoc/ocamldoc.hva +++ b/ocamldoc/ocamldoc.hva @@ -1,4 +1,5 @@ %(***********************************************************************) +%(* *) %(* OCamldoc *) %(* *) %(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index 6907749a..483db75f 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc.ml 10653 2010-08-24 11:48:46Z guesdon $ *) - (** Main module for bytecode. @todo coucou le todo*) @@ -30,8 +29,8 @@ let (plugins, paths) = let rec iter (files, incs) = function [] | _ :: [] -> (List.rev files, List.rev incs) | "-g" :: file :: q when - ((Filename.check_suffix file "cmo") or - (Filename.check_suffix file "cma") or + ((Filename.check_suffix file "cmo") || + (Filename.check_suffix file "cma") || (Filename.check_suffix file "cmxs")) -> iter (file :: files, incs) q | "-i" :: dir :: q -> diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 8eb26eaa..19621cb5 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_analyse.ml 12862 2012-08-16 09:44:48Z guesdon $ *) - (** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *) @@ -43,62 +42,12 @@ let initial_env () = (** Optionally preprocess a source file *) let preprocess sourcefile = - match !Clflags.preprocessor with - None -> sourcefile - | Some pp -> - let tmpfile = Filename.temp_file "ocamldocpp" "" in - let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in - if Ccomp.command comm <> 0 then begin - remove_file tmpfile; - Printf.eprintf "Preprocessing error\n"; - exit 2 - end; - tmpfile - -(** Remove the input file if this file was the result of a preprocessing.*) -let remove_preprocessed inputfile = - match !Clflags.preprocessor with - None -> () - | Some _ -> remove_file inputfile - -let remove_preprocessed_if_ast inputfile = - match !Clflags.preprocessor with - None -> () - | Some _ -> if inputfile <> !Location.input_name then remove_file inputfile - -exception Outdated_version - -(** Parse a file or get a dumped syntax tree in it *) -let parse_file inputfile parse_fun ast_magic = - let ic = open_in_bin inputfile in - let is_ast_file = - try - let buffer = Misc.input_bytes ic (String.length ast_magic) in - if buffer = ast_magic then true - else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - raise Outdated_version - else false - with - Outdated_version -> - fatal_error "OCaml and preprocessor have incompatible versions" - | _ -> false - in - let ast = - try - if is_ast_file then begin - Location.input_name := input_value ic; - input_value ic - end else begin - seek_in ic 0; - Location.input_name := inputfile; - let lexbuf = Lexing.from_channel ic in - Location.init lexbuf inputfile; - parse_fun lexbuf - end - with x -> close_in ic; raise x - in - close_in ic; - ast + try + Pparse.preprocess sourcefile + with Pparse.Error err -> + Format.eprintf "Preprocessing error@.%a@." + Pparse.report_error err; + exit 2 let (++) x f = f x @@ -112,7 +61,7 @@ let process_implementation_file ppf sourcefile = let inputfile = preprocess sourcefile in let env = initial_env () in try - let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in + let parsetree = Pparse.file Format.err_formatter inputfile Parse.implementation ast_impl_magic_number in let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree @@ -140,7 +89,7 @@ let process_interface_file ppf sourcefile = let modulename = String.capitalize(Filename.basename prefixname) in Env.set_unit_name modulename; let inputfile = preprocess sourcefile in - let ast = parse_file inputfile Parse.interface ast_intf_magic_number in + let ast = Pparse.file Format.err_formatter inputfile Parse.interface ast_intf_magic_number in let sg = Typemod.transl_signature (initial_env()) ast in Warnings.check_fatal (); (ast, sg, inputfile) @@ -175,29 +124,29 @@ let process_error exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Sys_error msg -> Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Translclass.Error(loc, err) -> Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; fprintf ppf @@ -238,7 +187,7 @@ let process_file ppf sourcefile = print_string Odoc_messages.ok; print_newline () ); - remove_preprocessed input_file; + Pparse.remove_preprocessed input_file; Some file_module with | Sys_error s @@ -267,7 +216,7 @@ let process_file ppf sourcefile = print_string Odoc_messages.ok; print_newline () ); - remove_preprocessed input_file; + Pparse.remove_preprocessed input_file; Some file_module with | Sys_error s diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli index 70c9009f..c155e81a 100644 --- a/ocamldoc/odoc_analyse.mli +++ b/ocamldoc/odoc_analyse.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_analyse.mli 10652 2010-08-24 09:45:45Z guesdon $ *) - (** Analysis of source files. *) (** This function builds the top modules from the analysis of the diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index ebc3d115..be5ce12f 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* cvsid $Id: odoc_args.ml 12221 2012-03-12 17:57:46Z guesdon $ *) - (** Command-line arguments. *) module M = Odoc_messages @@ -184,6 +183,7 @@ let default_options = [ (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs), M.include_dirs ; "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ; + "-ppx", Arg.String (fun s -> Odoc_global.ppx := s :: !Odoc_global.ppx), M.ppx ; "-impl", Arg.String (fun s -> Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]), M.option_impl ; diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index a9d11d77..c348dfa0 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_args.mli 12221 2012-03-12 17:57:46Z guesdon $ *) - (** Analysis of the command line arguments. *) (** The current module defining the generator to use. *) diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 2aa7caee..039bbb48 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_ast.ml 12951 2012-09-25 07:14:43Z guesdon $ *) - (** Analysis of implementation files. *) open Misc open Asttypes @@ -266,7 +265,7 @@ module Analyser = (List.map iter_pattern patlist, Odoc_env.subst_type env pat.pat_type) - | Typedtree.Tpat_construct (_, _, cons_desc, _, _) when + | Typedtree.Tpat_construct (_, cons_desc, _, _) when (* we give a name to the parameter only if it unit *) (match cons_desc.cstr_res.desc with Tconstr (p, _, _) -> @@ -557,12 +556,12 @@ module Analyser = | ((Parsetree.Pcf_val ({ txt = label }, mutable_flag, _, _) | Parsetree.Pcf_valvirt ({ txt = label }, mutable_flag, _) ) as x) -> - let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in - let complete_name = Name.concat current_class_name label in - let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in - let type_exp = - try Typedtree_search.search_attribute_type tt_cls label - with Not_found -> + let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let type_exp = + try Typedtree_search.search_attribute_type tt_cls label + with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name)) in let code = @@ -589,13 +588,13 @@ module Analyser = iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q | (Parsetree.Pcf_virt ({ txt = label }, private_flag, _)) -> - let complete_name = Name.concat current_class_name label in - let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in - let met_type = - try Odoc_sig.Signature_search.search_method_type label tt_class_sig - with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label)) - in - let real_type = + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let met_type = + try Odoc_sig.Signature_search.search_method_type label tt_class_sig + with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label)) + in + let real_type = match met_type.Types.desc with Tarrow (_, _, t, _) -> t @@ -631,9 +630,9 @@ module Analyser = iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q | (Parsetree.Pcf_meth ({ txt = label }, private_flag, _, _)) -> - let complete_name = Name.concat current_class_name label in - let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in - let exp = + let complete_name = Name.concat current_class_name label in + let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let exp = try Typedtree_search.search_method_expression tt_cls label with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name)) in @@ -1143,27 +1142,27 @@ module Analyser = let new_env = Odoc_env.add_value env new_value.val_name in (0, new_env, [Element_value new_value]) - | Parsetree.Pstr_type name_typedecl_list -> - (* of (string * type_declaration) list *) - (* we start by extending the environment *) - let new_env = - List.fold_left + | Parsetree.Pstr_type name_typedecl_list -> + (* of (string * type_declaration) list *) + (* we start by extending the environment *) + let new_env = + List.fold_left (fun acc_env -> fun ({ txt = name }, _) -> - let complete_name = Name.concat current_module_name name in - Odoc_env.add_type acc_env complete_name + let complete_name = Name.concat current_module_name name in + Odoc_env.add_type acc_env complete_name ) env name_typedecl_list - in - let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list = - match name_type_decl_list with - [] -> (maybe_more_acc, []) - | ({ txt = name }, type_decl) :: q -> - let complete_name = Name.concat current_module_name name in - let loc = type_decl.Parsetree.ptype_loc in - let loc_start = loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = loc.Location.loc_end.Lexing.pos_cnum in - let pos_limit2 = + in + let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list = + match name_type_decl_list with + [] -> (maybe_more_acc, []) + | ({ txt = name }, type_decl) :: q -> + let complete_name = Name.concat current_module_name name in + let loc = type_decl.Parsetree.ptype_loc in + let loc_start = loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let pos_limit2 = match q with [] -> pos_limit | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum @@ -1196,12 +1195,11 @@ module Analyser = ty_info = com_opt ; ty_parameters = List.map2 - (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) - tt_type_decl.Types.type_params - tt_type_decl.Types.type_variance ; + (fun p v -> + let (co, cn) = Types.Variance.get_upper v in + (Odoc_env.subst_type new_env p, co, cn)) + tt_type_decl.Types.type_params + tt_type_decl.Types.type_variance ; ty_kind = kind ; ty_private = tt_type_decl.Types.type_private; ty_manifest = @@ -1420,7 +1418,7 @@ module Analyser = in (0, new_env2, [ Element_module_type mt ]) - | Parsetree.Pstr_open longident -> + | Parsetree.Pstr_open (_, longident) -> (* A VOIR : enrichir l'environnement quand open ? *) let ele_comments = match comment_opt with None -> [] diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index a26610da..f1237f11 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_ast.mli 12511 2012-05-30 13:29:48Z lefessan $ *) - (** The module for analysing the typed abstract syntax tree and source code and creating modules, classes, ..., elements.*) type typedtree = Typedtree.structure * Typedtree.module_coercion diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml index 40c62824..ce9902eb 100644 --- a/ocamldoc/odoc_class.ml +++ b/ocamldoc/odoc_class.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_class.ml 12796 2012-07-30 11:22:29Z doligez $ *) - (** Representation and manipulation of classes and class types.*) module Name = Odoc_name @@ -248,6 +247,3 @@ let class_type_parameter_text_by_name clt label = with Not_found -> None - - -(* eof $Id: odoc_class.ml 12796 2012-07-30 11:22:29Z doligez $ *) diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index d7c89b2a..c39cb51b 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments.ml 12245 2012-03-14 21:01:41Z guesdon $ *) - (** Analysis of comments. *) open Odoc_types @@ -91,7 +90,7 @@ module Info_retriever = with Failure s -> incr Odoc_global.errors ; - prerr_endline (file^" : "^s^"\n"); + Printf.eprintf "File %S, line %d:\n%s\n%!" file (!Odoc_lexer.line_number + 1) s; (0, None) | Odoc_text.Text_syntax (l, c, s) -> incr Odoc_global.errors ; @@ -181,7 +180,7 @@ module Info_retriever = | (len, Some d) -> (* we check if the comment we got was really attached to the constructor, i.e. that there was no blank line or any special comment "(**" before *) - if (not strict) or (nothing_before_simple_comment s) then + if (not strict) || (nothing_before_simple_comment s) then (* ok, we attach the comment to the constructor *) (len, Some d) else @@ -261,7 +260,7 @@ module Info_retriever = (* if the special comment is the stop comment (**/**), then we must not associate it. *) let pos = Str.search_forward (Str.regexp_string "(**") s 0 in - if blank_line (String.sub s 0 pos) or + if blank_line (String.sub s 0 pos) || d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] then (0, None) @@ -294,7 +293,7 @@ module Info_retriever = | h :: q -> if (blank_line_outside_simple file (String.sub s len ((String.length s) - len)) ) - or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] + || h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] then (None, special_coms) else diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli index 6e1a3768..6aeb91de 100644 --- a/ocamldoc/odoc_comments.mli +++ b/ocamldoc/odoc_comments.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments.mli 7619 2006-09-20 11:14:37Z doligez $ *) - (** Analysis of comments. *) val simple_blank : string diff --git a/ocamldoc/odoc_comments_global.ml b/ocamldoc/odoc_comments_global.ml index 0b5d92f6..5fbe6406 100644 --- a/ocamldoc/odoc_comments_global.ml +++ b/ocamldoc/odoc_comments_global.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments_global.ml 10480 2010-05-31 11:52:13Z guesdon $ *) - (** The global variables used by the special comment parser.*) let nb_chars = ref 0 @@ -47,5 +46,3 @@ let init () = raised_exceptions := []; return_value := None ; customs := [] - -(* eof $Id: odoc_comments_global.ml 10480 2010-05-31 11:52:13Z guesdon $ *) diff --git a/ocamldoc/odoc_comments_global.mli b/ocamldoc/odoc_comments_global.mli index b00fdbc6..291673c0 100644 --- a/ocamldoc/odoc_comments_global.mli +++ b/ocamldoc/odoc_comments_global.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments_global.mli 10480 2010-05-31 11:52:13Z guesdon $ *) - (** The global variables used by the special comment parser.*) (** the number of chars used in the lexer. *) diff --git a/ocamldoc/odoc_config.ml b/ocamldoc/odoc_config.ml index 038b1caa..4250f514 100644 --- a/ocamldoc/odoc_config.ml +++ b/ocamldoc/odoc_config.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.ml 8416 2007-10-08 14:19:34Z doligez $ *) - let custom_generators_path = Filename.concat Config.standard_library (Filename.concat "ocamldoc" "custom") diff --git a/ocamldoc/odoc_config.mli b/ocamldoc/odoc_config.mli index f67a6117..59ffc098 100644 --- a/ocamldoc/odoc_config.mli +++ b/ocamldoc/odoc_config.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.mli 8416 2007-10-08 14:19:34Z doligez $ *) - (** Ocamldoc configuration contants. *) (** Default path to search for custom generators and to install them. *) diff --git a/ocamldoc/odoc_control.ml b/ocamldoc/odoc_control.ml index a282a21e..30a1f393 100644 --- a/ocamldoc/odoc_control.ml +++ b/ocamldoc/odoc_control.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -8,5 +9,3 @@ (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) - -(* $Id: odoc_control.ml 9547 2010-01-22 12:48:24Z doligez $ *) diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 2fe10b59..fcd60dc3 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_cross.ml 12249 2012-03-20 12:00:11Z guesdon $ *) - (** Cross referencing. *) module Name = Odoc_name @@ -156,7 +155,7 @@ let name_alias = module Map_ord = struct type t = string - let compare = Pervasives.compare + let compare (x:t) y = Pervasives.compare x y end module Ele_map = Map.Make (Map_ord) @@ -328,7 +327,7 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_ None -> (acc_b, (Name.head m.m_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) - (if ma.ma_name = Odoc_messages.struct_end or + (if ma.ma_name = Odoc_messages.struct_end || ma.ma_name = Odoc_messages.sig_end then acc_names else @@ -376,7 +375,7 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_ None -> (acc_b, (Name.head m.m_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) - (if mta.mta_name = Odoc_messages.struct_end or + (if mta.mta_name = Odoc_messages.struct_end || mta.mta_name = Odoc_messages.sig_end then acc_names else @@ -418,7 +417,7 @@ and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module None -> (acc_b, (Name.head mt.mt_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) - (if mta.mta_name = Odoc_messages.struct_end or + (if mta.mta_name = Odoc_messages.struct_end || mta.mta_name = Odoc_messages.sig_end then acc_names else @@ -454,7 +453,7 @@ and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_ None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) - (if im.im_name = Odoc_messages.struct_end or + (if im.im_name = Odoc_messages.struct_end || im.im_name = Odoc_messages.sig_end then acc_names_not_found else diff --git a/ocamldoc/odoc_cross.mli b/ocamldoc/odoc_cross.mli index 35e70b6a..57fff657 100644 --- a/ocamldoc/odoc_cross.mli +++ b/ocamldoc/odoc_cross.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_cross.mli 7619 2006-09-20 11:14:37Z doligez $ *) - (** Cross-referencing. *) val associate : Odoc_module.t_module list -> unit diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 4daf0f95..44a0aa9c 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_dag2html.ml 6723 2004-12-03 14:42:09Z guesdon $ *) - (** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *) type 'a dag = { mutable dag : 'a node array } @@ -349,7 +348,7 @@ let rec get_block t i j = ;; let group_by_common_children d list = - let module O = struct type t = idag;; let compare = compare;; end + let module O = struct type t = idag;; let compare (x:t) y = compare x y;; end in let module S = Set.Make (O) in @@ -605,7 +604,7 @@ let group_children t = if A and B have common children *) let group_span_by_common_children d t = - let module O = struct type t = idag;; let compare = compare;; end + let module O = struct type t = idag;; let compare (x:t) y = compare x y;; end in let module S = Set.Make (O) in diff --git a/ocamldoc/odoc_dag2html.mli b/ocamldoc/odoc_dag2html.mli index 2da9607b..d59148c7 100644 --- a/ocamldoc/odoc_dag2html.mli +++ b/ocamldoc/odoc_dag2html.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_dag2html.mli 9547 2010-01-22 12:48:24Z doligez $ *) - (** The types and functions to create a html table representing a dag. Thanks to Daniel de Rauglaudre. *) diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index a812260d..f2934ee3 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_dep.ml 11156 2011-07-27 14:17:02Z doligez $ *) - (** Top modules dependencies. *) module StrS = Depend.StringSet @@ -37,7 +36,10 @@ module Dep = struct type id = string - module S = Set.Make (struct type t = string let compare = compare end) + module S = Set.Make (struct + type t = string + let compare (x:t) y = compare x y + end) let set_to_list s = let l = ref [] in diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index b63f9ba0..60d6cd7e 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_dot.ml 12798 2012-07-30 11:53:27Z doligez $ *) - (** Definition of a class which outputs a dot file showing top modules dependencies.*) @@ -84,7 +83,7 @@ class dot = method generate_for_module fmt m = let l = List.filter (fun n -> - !dot_include_all or + !dot_include_all || (List.exists (fun m -> m.Module.m_name = n) modules)) m.Module.m_top_deps in diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index ff58d9f0..f4d1b7ce 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_env.ml 12796 2012-07-30 11:22:29Z doligez $ *) - (** Environment for finding complete names from relative names. *) let print_DEBUG s = print_string s ; print_newline ();; @@ -245,5 +244,3 @@ let subst_class_type env t = Types.Cty_fun (l, new_texp, new_ct) in iter t - -(* eof $Id: odoc_env.ml 12796 2012-07-30 11:22:29Z doligez $ *) diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli index 5eb92dfb..cafdd52e 100644 --- a/ocamldoc/odoc_env.mli +++ b/ocamldoc/odoc_env.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_env.mli 9547 2010-01-22 12:48:24Z doligez $ *) - (** Environment for finding complete names from relative names. *) (** An environment of known names, diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml index 5ff5c400..a62cb7b7 100644 --- a/ocamldoc/odoc_exception.ml +++ b/ocamldoc/odoc_exception.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_exception.ml 9547 2010-01-22 12:48:24Z doligez $ *) - (** Representation and manipulation of exceptions. *) module Name = Odoc_name diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml index b1909e78..a36ffbea 100644 --- a/ocamldoc/odoc_gen.ml +++ b/ocamldoc/odoc_gen.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamldoc/odoc_gen.mli b/ocamldoc/odoc_gen.mli index 37768c00..04987cf0 100644 --- a/ocamldoc/odoc_gen.mli +++ b/ocamldoc/odoc_gen.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Gallium, INRIA Rocquencourt *) diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml index 95c9118a..901febf1 100644 --- a/ocamldoc/odoc_global.ml +++ b/ocamldoc/odoc_global.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_global.ml 12798 2012-07-30 11:53:27Z doligez $ *) - (** Global variables. *) (* Tell ocaml compiler not to generate files. *) @@ -46,6 +45,7 @@ let recursive_types = Clflags.recursive_types (** Optional preprocessor command. *) let preprocessor = Clflags.preprocessor +let ppx = Clflags.all_ppx let sort_modules = ref false diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli index b107b306..2cf846c3 100644 --- a/ocamldoc/odoc_global.mli +++ b/ocamldoc/odoc_global.mli @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_global.mli 11156 2011-07-27 14:17:02Z doligez $ *) - (** Global variables. *) (** The kind of source file in arguments. *) @@ -23,7 +22,8 @@ type source_file = val include_dirs : string list ref (** Optional preprocessor command to pass to ocaml compiler. *) -val preprocessor : string option ref +val preprocessor : string option ref (* -pp *) +val ppx : string list ref (* -ppx *) (** Recursive types flag to passe to ocaml compiler. *) val recursive_types : bool ref diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index a4a5cfdb..a35df03b 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1,4 +1,5 @@ (***********************************************************************) +(* *) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) @@ -9,8 +10,6 @@ (* *) (***********************************************************************) -(* $Id: odoc_html.ml 12953 2012-09-25 07:50:40Z guesdon $ *) - (** Generation of html documentation.*) let print_DEBUG s = print_string s ; print_newline () @@ -205,7 +204,10 @@ module Naming = f end -module StringSet = Set.Make (struct type t = string let compare = compare end) +module StringSet = Set.Make (struct + type t = string + let compare (x:t) y = compare x y +end) (** A class with a method to colorize a string which represents OCaml code. *) class ocaml_code = @@ -669,13 +671,13 @@ class virtual info = @param indent can be specified not to use the style of info comments; default is [true]. *) - method html_of_info ?(indent=true) b info_opt = + method html_of_info ?(cls="") ?(indent=true) b info_opt = match info_opt with None -> () | Some info -> let module M = Odoc_info in - if indent then bs b "
\n"; + if indent then bs b ("
\n"); ( match info.M.i_deprecated with None -> () @@ -1397,7 +1399,7 @@ class html = (** Print html code for a value. *) method html_of_value b v = Odoc_info.reset_type_names (); - bs b "
" ;
+      bs b "\n
" ;
       bp b "" (Naming.value_target v);
       bs b (self#keyword "val");
       bs b " ";
@@ -1424,7 +1426,7 @@ class html =
     (** Print html code for an exception. *)
     method html_of_exception b e =
       Odoc_info.reset_type_names ();
-      bs b "
";
+      bs b "\n
";
       bp b "" (Naming.exception_target e);
       bs b (self#keyword "exception");
       bs b " ";
@@ -1459,12 +1461,12 @@ class html =
       let father = Name.father t.ty_name in
       bs b
         (match t.ty_manifest, t.ty_kind with
-          None, Type_abstract -> "
"
+          None, Type_abstract -> "\n
"
         | None, Type_variant _
-        | None, Type_record _ -> "
"
-        | Some _, Type_abstract -> "
"
+        | None, Type_record _ -> "\n
"
+        | Some _, Type_abstract -> "\n
"
         | Some _, Type_variant _
-        | Some _, Type_record _ -> "
"
+        | Some _, Type_record _ -> "\n
"
         );
       bp b "" (Naming.type_target t);
       bs b ((self#keyword "type")^" ");
@@ -1557,7 +1559,7 @@ class html =
             bs b "\n\n";
             bs b "";
             if r.rf_mutable then bs b (self#keyword "mutable ") ;
-            bp b "%s :"
+            bp b "%s : "
               (Naming.recfield_target t r)
               r.rf_name;
             self#html_of_type_expr b father r.rf_type;
@@ -1587,7 +1589,7 @@ class html =
     (** Print html code for a class attribute. *)
     method html_of_attribute b a =
       let module_name = Name.father (Name.father a.att_value.val_name) in
-      bs b "
" ;
+      bs b "\n
" ;
       bp b "" (Naming.attribute_target a);
       bs b (self#keyword "val");
       bs b " ";
@@ -1619,7 +1621,7 @@ class html =
     (** Print html code for a class method. *)
     method html_of_method b m =
       let module_name = Name.father (Name.father m.met_value.val_name) in
-      bs b "
";
+      bs b "\n
";
       (* html mark *)
       bp b "" (Naming.method_target m);
      bs b ((self#keyword "method")^" ");
@@ -1763,7 +1765,7 @@ class html =
     method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
       let (html_file, _) = Naming.html_files m.m_name in
       let father = Name.father m.m_name in
-      bs b "
";
+      bs b "\n
";
       bs b ((self#keyword "module")^" ");
       (
        if with_link then
@@ -1782,7 +1784,7 @@ class html =
       if info then
         (
          if complete then
-           self#html_of_info ~indent: true
+           self#html_of_info ~cls: "module top" ~indent: true
          else
            self#html_of_info_first_sentence
         ) b m.m_info
@@ -1793,7 +1795,7 @@ class html =
     method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt =
       let (html_file, _) = Naming.html_files mt.mt_name in
       let father = Name.father mt.mt_name in
-      bs b "
";
+      bs b "\n
";
       bs b ((self#keyword "module type")^" ");
       (
        if with_link then
@@ -1811,7 +1813,7 @@ class html =
       if info then
         (
          if complete then
-           self#html_of_info ~indent: true
+           self#html_of_info ~cls: "modtype top" ~indent: true
          else
            self#html_of_info_first_sentence
         ) b mt.mt_info
@@ -1820,7 +1822,7 @@ class html =
 
     (** Print html code for an included module. *)
     method html_of_included_module b im =
-      bs b "
";
+      bs b "\n
";
       bs b ((self#keyword "include")^" ");
       (
        match im.im_module with
@@ -1931,7 +1933,7 @@ class html =
       let father = Name.father c.cl_name in
       Odoc_info.reset_type_names ();
       let (html_file, _) = Naming.html_files c.cl_name in
-      bs b "
";
+      bs b "\n
";
       (* 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 ""
@@ -1968,7 +1970,7 @@ class html =
       print_DEBUG "html#html_of_class : info" ;
       (
        if complete then
-         self#html_of_info ~indent: true
+         self#html_of_info ~cls: "class top" ~indent: true
        else
          self#html_of_info_first_sentence
       ) b c.cl_info
@@ -1978,7 +1980,7 @@ class html =
       Odoc_info.reset_type_names ();
       let father = Name.father ct.clt_name in
       let (html_file, _) = Naming.html_files ct.clt_name in
-      bs b "
";
+      bs b "\n
";
       (* we add a html id, the same as for a type so we can
          go directly here when the class type name is used as a type name *)
       bp b ""
@@ -2011,7 +2013,7 @@ class html =
       bs b "
";
       (
        if complete then
-         self#html_of_info ~indent: true
+         self#html_of_info ~cls: "classtype top" ~indent: true
        else
          self#html_of_info_first_sentence
       ) b ct.clt_info
diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
index 54fadaba..4a6c2141 100644
--- a/ocamldoc/odoc_info.ml
+++ b/ocamldoc/odoc_info.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_info.ml 12435 2012-05-07 10:31:18Z guesdon $ *)
-
 (** Interface for analysing documented OCaml source files and to the collected information. *)
 
 type ref_kind = Odoc_types.ref_kind =
diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index 4f42986e..ae888300 100644
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_info.mli 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** Interface to the information collected in source files. *)
 
 (** The differents kinds of element references. *)
diff --git a/ocamldoc/odoc_inherit.ml b/ocamldoc/odoc_inherit.ml
index fa50fb04..30a1f393 100644
--- a/ocamldoc/odoc_inherit.ml
+++ b/ocamldoc/odoc_inherit.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -8,5 +9,3 @@
 (*  under the terms of the Q Public License version 1.0.               *)
 (*                                                                     *)
 (***********************************************************************)
-
-(* $Id: odoc_inherit.ml 9547 2010-01-22 12:48:24Z doligez $ *)
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index bec8b91c..7d026f46 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_latex.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** Generation of LaTeX documentation. *)
 
 let print_DEBUG s = print_string s ; print_newline ()
diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml
index d22979cd..713e72e8 100644
--- a/ocamldoc/odoc_latex_style.ml
+++ b/ocamldoc/odoc_latex_style.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -11,8 +12,6 @@
 
 (** The content of the LaTeX style to generate when generating LaTeX code. *)
 
-(* $Id: odoc_latex_style.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 let content ="\
 \n%% Support macros for LaTeX documentation generated by ocamldoc.\
 \n%% This file is in the public domain; do what you want with it.\
diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
index 4b8dcb9f..998d31bd 100644
--- a/ocamldoc/odoc_lexer.mll
+++ b/ocamldoc/odoc_lexer.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_lexer.mll 12796 2012-07-30 11:22:29Z doligez $ *)
-
 (** The lexer for special comments. *)
 
 open Lexing
@@ -295,6 +293,10 @@ and elements = parse
         incr Odoc_comments_global.nb_chars;
         print_DEBUG2 "newline";
         elements lexbuf }
+  | "@"
+      {
+        raise (Failure (Odoc_messages.should_escape_at_sign))
+      }
 
   | "@"lowercase+
       {
@@ -341,6 +343,10 @@ and elements = parse
       {
         EOF
       }
+  | _ {
+        let s = Lexing.lexeme lexbuf in
+        failwith ("Unexpected character '"^s^"'")
+      }
 
 
 and simple = parse
diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 4a813da4..7e01f8d4 100644
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_man.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** The man pages generator. *)
 open Odoc_info
 open Parameter
diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index b591b9d3..1e94c273 100644
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_merge.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
 open Odoc_types
@@ -995,7 +994,7 @@ let merge merge_options modules_list =
                    raise (Failure (Odoc_messages.two_interfaces m.m_name))
             )
         | _ ->
-            (* two many Module.t ! *)
+            (* too many Module.t ! *)
             raise (Failure (Odoc_messages.too_many_module_objects m.m_name))
 
   in
diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
index a28e8fb5..2b6b857b 100644
--- a/ocamldoc/odoc_merge.mli
+++ b/ocamldoc/odoc_merge.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_merge.mli 12796 2012-07-30 11:22:29Z doligez $ *)
-
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
 (** Merging \@before tags. *)
diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index 0f5f3104..2d6327bb 100644
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_messages.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
 (** The messages of the application. *)
 
 let ok = "Ok"
@@ -35,6 +34,7 @@ let verbose_mode = "\t\tverbose mode"
 let include_dirs = "\tAdd  to the list of include directories"
 let rectypes = "\tAllow arbitrary recursive types"
 let preprocess = "\tPipe sources through preprocessor "
+let ppx = "\n\t\tPipe abstract syntax tree through preprocessor "
 let option_impl ="\tConsider  as a .ml file"
 let option_intf ="\tConsider  as a .mli file"
 let option_text ="\tConsider  as a .txt file"
@@ -246,6 +246,7 @@ let file_not_found_in_paths paths name =
     (String.concat "\n" paths)
 
 let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
+let should_escape_at_sign = "The character @ has a special meaning in ocamldoc comments, for commands such as @raise or @since. If you want to write a single @, you must escape it as \\@."
 let bad_tree = "Incorrect tree structure."
 let not_a_valid_tag s = s^" is not a valid tag."
 let fun_without_param f = "Function "^f^" has no parameter.";;
@@ -256,7 +257,7 @@ let implicit_match_in_parameter = "Parameters contain implicit pattern matching.
 let unknown_extension f = "Unknown extension for file "^f^"."
 let two_implementations name = "There are two implementations of module "^name^"."
 let two_interfaces name = "There are two interfaces of module "^name^"."
-let too_many_module_objects name = "There are two many interfaces/implementation of module "^name^"."
+let too_many_module_objects name = "There are too many interfaces/implementation of module "^name^"."
 let exception_not_found_in_implementation exc m = "Exception "^exc^" was not found in implementation of module "^m^"."
 let type_not_found_in_implementation exc m = "Type "^exc^" was not found in implementation of module "^m^"."
 let module_not_found_in_implementation m m2 = "Module "^m^" was not found in implementation of module "^m2^"."
diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index 29a46655..c762ade2 100644
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_misc.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
 let no_blanks s =
   let len = String.length s in
   let buf = Buffer.create len in
diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
index 06b66fc3..5958be91 100644
--- a/ocamldoc/odoc_misc.mli
+++ b/ocamldoc/odoc_misc.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,9 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_misc.mli 7307 2006-01-04 16:55:50Z doligez $ *)
-
-(** Miscelaneous functions *)
+(** Miscellaneous functions *)
 
 (** [no_blanks s] returns the given string without any blank
    characters, i.e. '\n' '\r' ' ' '\t'.
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index 4f9a0fd3..216f1cfb 100644
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_module.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (** Representation and manipulation of modules and module types. *)
 
 let print_DEBUG s = print_string s ; print_newline ()
diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
index f9b9b1ca..bdb1f58c 100644
--- a/ocamldoc/odoc_name.ml
+++ b/ocamldoc/odoc_name.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_name.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** Representation of element names. *)
 
 let infix_chars = [ '|' ;
@@ -151,10 +150,10 @@ let depth name =
     _ -> 1
 
 let prefix n1 n2 =
-  (n1 <> n2) &
+  (n1 <> n2) &&
   (try
     let len1 = String.length n1 in
-    ((String.sub n2 0 len1) = n1) &
+    ((String.sub n2 0 len1) = n1) &&
     (n2.[len1] = '.')
   with _ -> false)
 
@@ -162,10 +161,10 @@ let rec get_relative_raw n1 n2 =
   let (f1,s1) = head_and_tail n1 in
   let (f2,s2) = head_and_tail n2 in
   if f1 = f2 then
-    if f2 = s2 or s2 = "" then
+    if f2 = s2 || s2 = "" then
       s2
     else
-      if f1 = s1 or s1 = "" then
+      if f1 = s1 || s1 = "" then
         s2
       else
         get_relative_raw s1 s2
diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli
index 8f21e53b..9c0e51ec 100644
--- a/ocamldoc/odoc_name.mli
+++ b/ocamldoc/odoc_name.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_name.mli 12622 2012-06-21 05:46:28Z guesdon $ *)
-
 (** Representation of element names. *)
 
 type t = string
diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
index 4fdc54b5..975229da 100644
--- a/ocamldoc/odoc_ocamlhtml.mll
+++ b/ocamldoc/odoc_ocamlhtml.mll
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_ocamlhtml.mll 9547 2010-01-22 12:48:24Z doligez $ *)
-
 (** Generation of html code to display OCaml code. *)
 open Lexing
 
diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml
index 24723a14..be98ef41 100644
--- a/ocamldoc/odoc_parameter.ml
+++ b/ocamldoc/odoc_parameter.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_parameter.ml 9547 2010-01-22 12:48:24Z doligez $ *)
-
 (** Representation and manipulation of method / function / class parameters. *)
 
 let print_DEBUG s = print_string s ; print_newline ()
diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
index 5a3ab6ae..ea7d9a57 100644
--- a/ocamldoc/odoc_parser.mly
+++ b/ocamldoc/odoc_parser.mly
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_parser.mly 10480 2010-05-31 11:52:13Z guesdon $ *)
-
 open Odoc_types
 open Odoc_comments_global
 
diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 3c3c22b5..a62832fd 100644
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_print.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
 open Format
 
 let new_fmt () =
diff --git a/ocamldoc/odoc_print.mli b/ocamldoc/odoc_print.mli
index 2575db90..f7c59013 100644
--- a/ocamldoc/odoc_print.mli
+++ b/ocamldoc/odoc_print.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_print.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
 (** Printing functions. *)
 
 (** This function takes a Types.type_expr and returns a string.
diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 6b1b392f..e507c48b 100644
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_scan.ml 12796 2012-07-30 11:22:29Z doligez $ *)
-
 (** Scanning of modules and elements.
 
    The class scanner defined in this module can be used to
diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index 428294fa..4e76d9fe 100644
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_search.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
 (** Research of elements through modules. *)
 
 module Name = Odoc_name
@@ -679,5 +678,3 @@ let find_section mods regexp =
   with
     Res_section (_,t) -> t
   | _ -> assert false
-
-(* eof $Id: odoc_search.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
index 373fdd91..bd101aa5 100644
--- a/ocamldoc/odoc_search.mli
+++ b/ocamldoc/odoc_search.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_search.mli 12249 2012-03-20 12:00:11Z guesdon $ *)
-
 (** Research of elements through modules. *)
 
 (** The type for an element of the result of a research. *)
diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll
index 9358611d..59ffc937 100644
--- a/ocamldoc/odoc_see_lexer.mll
+++ b/ocamldoc/odoc_see_lexer.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_see_lexer.mll 9547 2010-01-22 12:48:24Z doligez $ *)
-
 let print_DEBUG2 s = print_string s ; print_newline ()
 
 (** the lexer for special comments. *)
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index f5d56681..24beb028 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_sig.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** Analysis of interface files. *)
 
 open Misc
@@ -639,10 +638,9 @@ module Analyser =
                       ty_name = Name.concat current_module_name name.txt ;
                       ty_info = assoc_com ;
                       ty_parameters =
-                        List.map2 (fun p (co,cn,_) ->
-                                     (Odoc_env.subst_type new_env p,
-                                      co, cn)
-                                  )
+                        List.map2 (fun p v ->
+                          let (co, cn) = Types.Variance.get_upper v in
+                          (Odoc_env.subst_type new_env p,co, cn))
                         sig_type_decl.Types.type_params
                         sig_type_decl.Types.type_variance;
                       ty_kind = type_kind;
@@ -893,7 +891,7 @@ module Analyser =
                 im_info = comment_opt;
               }
             in
-            (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
+            (0, env, [ Element_included_module im ]) (* A VOIR : etendre l'environnement ? avec quoi ? *)
 
         | Parsetree.Psig_class class_description_list ->
             (* we start by extending the environment *)
@@ -1239,7 +1237,7 @@ module Analyser =
             )
           else
             (
-             raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
+             raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels differents")
             )
 
       | _ ->
diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index cd2ca50a..f0c3c4a1 100644
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_sig.mli 12622 2012-06-21 05:46:28Z guesdon $ *)
-
 (** The module for analysing a signature and source code and creating modules, classes, ..., elements.*)
 
 (** The functions used to retrieve information from a signature. *)
diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index 46707d38..5f3a8e9e 100644
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_str.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (** The functions to get a string from different kinds of elements (types, modules, ...). *)
 
 module Name = Odoc_name
@@ -283,5 +282,3 @@ let string_of_method m =
   (match m.M.met_value.M.val_info with
     None -> ""
   | Some i -> Odoc_misc.string_of_info i)
-
-(* eof $Id: odoc_str.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli
index 1216b237..44278bb0 100644
--- a/ocamldoc/odoc_str.mli
+++ b/ocamldoc/odoc_str.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_str.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
 (** The functions to get a string from different kinds of elements (types, modules, ...). *)
 
 (** @return the variance string for the given type and (covariant, contravariant) information. *)
diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
index 4df2fb9a..cd7b5fa0 100644
--- a/ocamldoc/odoc_test.ml
+++ b/ocamldoc/odoc_test.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_test.ml 12221 2012-03-12 17:57:46Z guesdon $ *)
-
 (** Custom generator to perform test on ocamldoc. *)
 
 open Odoc_info
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index 48fb55b5..067586b8 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*      Olivier Andrieu, base sur du code de Maxence Guesdon           *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_texi.ml 12798 2012-07-30 11:53:27Z doligez $ *)
-
 (** Generation of Texinfo documentation. *)
 
 open Odoc_info
diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
index 0747721e..4fd30e0e 100644
--- a/ocamldoc/odoc_text.ml
+++ b/ocamldoc/odoc_text.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_text.ml 12249 2012-03-20 12:00:11Z guesdon $ *)
-
 exception Text_syntax of int * int * string (* line, char, string *)
 
 open Odoc_types
diff --git a/ocamldoc/odoc_text.mli b/ocamldoc/odoc_text.mli
index f359a244..fc4f3306 100644
--- a/ocamldoc/odoc_text.mli
+++ b/ocamldoc/odoc_text.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_text.mli 9547 2010-01-22 12:48:24Z doligez $ *)
-
 (** A module with a function to parse strings to obtain a [Odoc_types.text] value. *)
 
 (** Syntax error in a text. *)
diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
index b2b8ecc5..aaaff105 100644
--- a/ocamldoc/odoc_text_lexer.mll
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_text_lexer.mll 12796 2012-07-30 11:22:29Z doligez $ *)
-
 (** The lexer for string to build text structures. *)
 
 open Lexing
@@ -188,7 +186,7 @@ rule main = parse
     {
       print_DEBUG "end";
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
+      if !verb_mode || !target_mode || !code_pre_mode ||
         (!open_brackets >= 1) then
         Char (Lexing.lexeme lexbuf)
       else
@@ -202,8 +200,8 @@ rule main = parse
     {
       print_DEBUG "begin_title";
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         let s = Lexing.lexeme lexbuf in
@@ -231,8 +229,8 @@ rule main = parse
 | begin_bold
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         BOLD
@@ -240,8 +238,8 @@ rule main = parse
 | begin_italic
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         ITALIC
@@ -249,8 +247,8 @@ rule main = parse
 | begin_link
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         LINK
@@ -258,8 +256,8 @@ rule main = parse
 | begin_emp
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         EMP
@@ -267,8 +265,8 @@ rule main = parse
 | begin_superscript
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         SUPERSCRIPT
@@ -276,8 +274,8 @@ rule main = parse
 | begin_subscript
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         SUBSCRIPT
@@ -285,8 +283,8 @@ rule main = parse
 | begin_center
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         CENTER
@@ -294,8 +292,8 @@ rule main = parse
 | begin_left
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         LEFT
@@ -303,8 +301,8 @@ rule main = parse
 | begin_right
      {
       incr_cpts lexbuf ;
-       if !verb_mode or !target_mode or !code_pre_mode
-           or (!open_brackets >= 1) or !ele_ref_mode then
+       if !verb_mode || !target_mode || !code_pre_mode
+           || (!open_brackets >= 1) || !ele_ref_mode then
          Char (Lexing.lexeme lexbuf)
        else
          RIGHT
@@ -313,8 +311,8 @@ rule main = parse
     {
       print_DEBUG "LIST";
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         LIST
@@ -322,8 +320,8 @@ rule main = parse
 | begin_enum
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         ENUM
@@ -332,8 +330,8 @@ rule main = parse
     {
       print_DEBUG "ITEM";
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         ITEM
@@ -341,8 +339,8 @@ rule main = parse
 | begin_target
    {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         (
@@ -359,8 +357,8 @@ rule main = parse
 | begin_latex
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         (
@@ -371,7 +369,7 @@ rule main = parse
 | end_target
     {
       incr_cpts lexbuf ;
-      if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or
+      if !verb_mode || (!open_brackets >= 1) || !code_pre_mode ||
         !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
@@ -389,7 +387,7 @@ rule main = parse
 | begin_code
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         if !open_brackets <= 0 then
@@ -406,7 +404,7 @@ rule main = parse
 | end_code
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         if !open_brackets > 1 then
@@ -430,7 +428,7 @@ rule main = parse
 | begin_code_pre
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         (
@@ -441,7 +439,7 @@ rule main = parse
 | end_code_pre
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !ele_ref_mode then
+      if !verb_mode || !target_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         if !open_brackets >= 1 then
@@ -482,7 +480,7 @@ rule main = parse
 | begin_ele_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -500,7 +498,7 @@ rule main = parse
 | begin_val_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -517,7 +515,7 @@ rule main = parse
 | begin_typ_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -534,7 +532,7 @@ rule main = parse
 | begin_exc_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -551,7 +549,7 @@ rule main = parse
 | begin_mod_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -568,7 +566,7 @@ rule main = parse
 | begin_modt_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -585,7 +583,7 @@ rule main = parse
 | begin_cla_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -602,7 +600,7 @@ rule main = parse
 | begin_clt_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -619,7 +617,7 @@ rule main = parse
 | begin_att_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -636,7 +634,7 @@ rule main = parse
 | begin_met_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -653,7 +651,7 @@ rule main = parse
 | begin_sec_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -669,7 +667,7 @@ rule main = parse
 | begin_recf_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -685,7 +683,7 @@ rule main = parse
 | begin_const_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -701,7 +699,7 @@ rule main = parse
 | begin_mod_list_ref
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -718,7 +716,7 @@ rule main = parse
 | index_list
     {
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+      if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then
         Char (Lexing.lexeme lexbuf)
       else
         if not !ele_ref_mode then
@@ -730,7 +728,7 @@ rule main = parse
 | begin_verb
     {
       incr_cpts lexbuf ;
-      if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         (
@@ -741,7 +739,7 @@ rule main = parse
 | end_verb
     {
       incr_cpts lexbuf ;
-      if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         (
@@ -799,7 +797,7 @@ rule main = parse
          END_SHORTCUT_LIST
         )
       else
-        if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then
+        if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode || !verb_mode then
           Char (Lexing.lexeme lexbuf)
         else
           BLANK_LINE
@@ -811,8 +809,8 @@ rule main = parse
     {
       print_DEBUG "begin_custom";
       incr_cpts lexbuf ;
-      if !verb_mode or !target_mode or !code_pre_mode or
-        (!open_brackets >= 1) or !ele_ref_mode then
+      if !verb_mode || !target_mode || !code_pre_mode ||
+        (!open_brackets >= 1) || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         let s = Lexing.lexeme lexbuf in
@@ -825,7 +823,7 @@ rule main = parse
 |  "{"
     {
       incr_cpts lexbuf ;
-      if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode then
         Char (Lexing.lexeme lexbuf)
       else
         LBRACE
diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index e9d9e705..c10425cc 100644
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_text_parser.mly 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open Odoc_types
 
 let identchar =
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index 4e44a9ec..7b08417e 100644
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_to_text.ml 10480 2010-05-31 11:52:13Z guesdon $ *)
-
 (** Text generation.
 
    This module contains the class [to_text] with methods used to transform
diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index b4d16810..fefd007c 100644
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_type.ml 11160 2011-07-29 10:32:43Z garrigue $ *)
-
 (** Representation and manipulation of a type, but not class nor module type.*)
 
 module Name = Odoc_name
diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
index 73b7ad7f..eccc852d 100644
--- a/ocamldoc/odoc_types.ml
+++ b/ocamldoc/odoc_types.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_types.ml 12435 2012-05-07 10:31:18Z guesdon $ *)
-
 type ref_kind =
     RK_module
   | RK_module_type
diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
index ee380e7a..7819a234 100644
--- a/ocamldoc/odoc_types.mli
+++ b/ocamldoc/odoc_types.mli
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_types.mli 12435 2012-05-07 10:31:18Z guesdon $ *)
-
 (** Types for the information collected in comments. *)
 
 (** The differents kinds of element references. *)
diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
index b7487f53..b35f2c6b 100644
--- a/ocamldoc/odoc_value.ml
+++ b/ocamldoc/odoc_value.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_value.ml 11210 2011-09-22 09:05:42Z garrigue $ *)
-
 (** Representation and manipulation of values, class attributes and class methods. *)
 
 module Name = Odoc_name
diff --git a/ocamldoc/remove_DEBUG b/ocamldoc/remove_DEBUG
index 691c4899..bca6ba04 100755
--- a/ocamldoc/remove_DEBUG
+++ b/ocamldoc/remove_DEBUG
@@ -11,8 +11,6 @@
 #(*                                                                     *)
 #(***********************************************************************)
 
-# $Id: remove_DEBUG 11156 2011-07-27 14:17:02Z doligez $
-
 # usage: remove_DEBUG 
 # remove from  every line that contains the string "DEBUG",
 # respecting the cpp # line annotation conventions
diff --git a/ocamldoc/runocamldoc b/ocamldoc/runocamldoc
index 6ef1235b..d2112e9c 100644
--- a/ocamldoc/runocamldoc
+++ b/ocamldoc/runocamldoc
@@ -12,8 +12,6 @@
 #                                                                     #
 #######################################################################
 
-# $Id: runocamldoc 11156 2011-07-27 14:17:02Z doligez $
-
 case "$1" in
   true) shift
         exec ../boot/ocamlrun  -I ../otherlibs/unix -I ../otherlibs/str \
diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index 014b89de..6c3e58aa 100644
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 # Common Makefile for otherlibs on the Unix ports
 
 CAMLC=$(ROOTDIR)/ocamlcomp.sh
diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt
index e0f95468..aafb4217 100644
--- a/otherlibs/Makefile.nt
+++ b/otherlibs/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 # Common Makefile for otherlibs on the Win32/MinGW ports
 
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s
diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared
index 2c084a02..4e8092f9 100644
--- a/otherlibs/Makefile.shared
+++ b/otherlibs/Makefile.shared
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.shared 11156 2011-07-27 14:17:02Z doligez $
-
 # Common Makefile for otherlibs
 
 ROOTDIR=../..
@@ -21,7 +19,7 @@ include $(ROOTDIR)/config/Makefile
 # Compilation options
 CC=$(BYTECC)
 CAMLRUN=$(ROOTDIR)/boot/ocamlrun
-COMPFLAGS=-warn-error A -g $(EXTRACAMLFLAGS)
+COMPFLAGS=-w +33..39 -warn-error A -g $(EXTRACAMLFLAGS)
 MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
 
 # Variables to be defined by individual libraries:
@@ -45,10 +43,12 @@ all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
 allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
 
 $(LIBNAME).cma: $(CAMLOBJS)
-	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
+	         $(CAMLOBJS) $(LINKOPTS)
 
 $(LIBNAME).cmxa: $(CAMLOBJS_NAT)
-	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS)
+	$(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
+	         $(CAMLOBJS_NAT) $(LINKOPTS)
 
 $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
 	$(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index 889328a3..d705f202 100644
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -5,7 +5,7 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
   ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \
   ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h
+  ../../byterun/minor_gc.h ../../byterun/int64_native.h
 mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \
   ../../byterun/../config/m.h ../../byterun/../config/s.h \
   ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \
diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index d442edb7..84ca80a5 100644
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 LIBNAME=bigarray
 EXTRACFLAGS=-I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
 EXTRACAMLFLAGS=-I ../unix
diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
index 85e35ea8..db5ed605 100644
--- a/otherlibs/bigarray/Makefile.nt
+++ b/otherlibs/bigarray/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 LIBNAME=bigarray
 EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
 EXTRACAMLFLAGS=-I ../win32unix
diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
index 7cd7052e..26fdcc9e 100644
--- a/otherlibs/bigarray/bigarray.h
+++ b/otherlibs/bigarray/bigarray.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bigarray.h 12311 2012-04-03 13:49:17Z xleroy $ */
-
 #ifndef CAML_BIGARRAY_H
 #define CAML_BIGARRAY_H
 
@@ -81,6 +79,13 @@ struct caml_ba_array {
 #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)
diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
index 2d2cdf1c..0aea1f4c 100644
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: bigarray.ml 12433 2012-05-06 08:23:37Z xleroy $ *)
-
 (* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
 
 external init : unit -> unit = "caml_ba_init"
@@ -96,7 +94,7 @@ module Genarray = struct
   external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill"
   external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout ->
                      bool -> int array -> int64 -> ('a, 'b, 'c) t
-                     = "caml_ba_map_file_bytecode" "caml_ba_map_file"
+     = "caml_ba_map_file_bytecode" "caml_ba_map_file"
   let map_file fd ?(pos = 0L) kind layout shared dims =
     map_internal fd kind layout shared dims pos
 end
@@ -108,8 +106,9 @@ module Array1 = struct
   external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
   external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1"
   external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
-  external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1"
-  let dim a = Genarray.nth_dim a 0
+  external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_1"
+  external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub"
@@ -130,17 +129,19 @@ module Array2 = struct
     Genarray.create kind layout [|dim1; dim2|]
   external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
   external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2"
-  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2"
-  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2"
-  let dim1 a = Genarray.nth_dim a 0
-  let dim2 a = Genarray.nth_dim a 1
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
+     = "%caml_ba_unsafe_ref_2"
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_2"
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
-    = "caml_ba_sub"
+     = "caml_ba_sub"
   external sub_right:
     ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
-    = "caml_ba_sub"
+     = "caml_ba_sub"
   let slice_left a n = Genarray.slice_left a [|n|]
   let slice_right a n = Genarray.slice_right a [|n|]
   external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
@@ -169,19 +170,21 @@ module Array3 = struct
     Genarray.create kind layout [|dim1; dim2; dim3|]
   external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
   external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
-    = "%caml_ba_set_3"
-  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3"
-  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3"
-  let dim1 a = Genarray.nth_dim a 0
-  let dim2 a = Genarray.nth_dim a 1
-  let dim3 a = Genarray.nth_dim a 2
+     = "%caml_ba_set_3"
+  external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
+     = "%caml_ba_unsafe_ref_3"
+  external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
+     = "%caml_ba_unsafe_set_3"
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
+  external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
-    = "caml_ba_sub"
+     = "caml_ba_sub"
   external sub_right:
-    ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
-    = "caml_ba_sub"
+     ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t
+     = "caml_ba_sub"
   let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
   let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
   let slice_left_2 a n = Genarray.slice_left a [|n|]
@@ -213,11 +216,11 @@ module Array3 = struct
 end
 
 external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t
-  = "%identity"
+   = "%identity"
 external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t
-  = "%identity"
+   = "%identity"
 external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t
-  = "%identity"
+   = "%identity"
 let array1_of_genarray a =
   if Genarray.num_dims a = 1 then a
   else invalid_arg "Bigarray.array1_of_genarray"
diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index 89aaccea..eb9f3c5c 100644
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -11,12 +11,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: bigarray.mli 12772 2012-07-24 22:43:01Z doligez $ *)
-
 (** Large, multi-dimensional, numerical arrays.
 
    This module implements multi-dimensional arrays of integers and
-   floating-point numbers, thereafter referred to as ``big arrays''.
+   floating-point numbers, thereafter referred to as 'big arrays'.
    The implementation allows efficient sharing of large numerical
    arrays between OCaml code and C or Fortran numerical libraries.
 
@@ -333,7 +331,7 @@ module Genarray :
     = "caml_ba_slice"
   (** Extract a sub-array of lower dimension from the given big array
      by fixing one or several of the first (left-most) coordinates.
-     [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice''
+     [Genarray.slice_left a [|i1; ... ; iM|]] returns the 'slice'
      of [a] obtained by setting the first [M] coordinates to
      [i1], ..., [iM].  If [a] has [N] dimensions, the slice has
      dimension [N - M], and the element at coordinates
@@ -351,7 +349,7 @@ module Genarray :
     = "caml_ba_slice"
   (** Extract a sub-array of lower dimension from the given big array
      by fixing one or several of the last (right-most) coordinates.
-     [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice''
+     [Genarray.slice_right a [|i1; ... ; iM|]] returns the 'slice'
      of [a] obtained by setting the last [M] coordinates to
      [i1], ..., [iM].  If [a] has [N] dimensions, the slice has
      dimension [N - M], and the element at coordinates
@@ -448,7 +446,7 @@ module Array1 : sig
      determine the array element kind and the array layout
      as described for [Genarray.create]. *)
 
-  val dim: ('a, 'b, 'c) t -> int
+  external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
   (** Return the size (dimension) of the given one-dimensional
      big array. *)
 
@@ -528,10 +526,10 @@ module Array2 :
      determine the array element kind and the array layout
      as described for {!Bigarray.Genarray.create}. *)
 
-  val dim1: ('a, 'b, 'c) t -> int
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
   (** Return the first dimension of the given two-dimensional big array. *)
 
-  val dim2: ('a, 'b, 'c) t -> int
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
   (** Return the second dimension of the given two-dimensional big array. *)
 
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
@@ -631,13 +629,13 @@ module Array3 :
      [kind] and [layout] determine the array element kind and
      the array layout as described for {!Bigarray.Genarray.create}. *)
 
-  val dim1: ('a, 'b, 'c) t -> int
+  external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1"
   (** Return the first dimension of the given three-dimensional big array. *)
 
-  val dim2: ('a, 'b, 'c) t -> int
+  external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2"
   (** Return the second dimension of the given three-dimensional big array. *)
 
-  val dim3: ('a, 'b, 'c) t -> int
+  external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3"
   (** Return the third dimension of the given three-dimensional big array. *)
 
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index 15f5fb2b..f30fa4cc 100644
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bigarray_stubs.c 12963 2012-09-27 15:48:40Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -160,12 +158,7 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
     if (data == NULL && size != 0) caml_raise_out_of_memory();
     flags |= CAML_BA_MANAGED;
   }
-  /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
-  asize = sizeof(struct caml_ba_array) + num_dims * sizeof(intnat);
-#else
-  asize = sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat);
-#endif
+  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;
@@ -353,6 +346,75 @@ CAMLprim value caml_ba_get_generic(value vb, value vind)
   return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
 }
 
+
+CAMLprim value caml_ba_uint8_get16(value vb, value vind)
+{
+  intnat res;
+  unsigned char b1, b2;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+#ifdef ARCH_BIG_ENDIAN
+  res = b1 << 8 | b2;
+#else
+  res = b2 << 8 | b1;
+#endif
+  return Val_int(res);
+}
+
+CAMLprim value caml_ba_uint8_get32(value vb, value vind)
+{
+  intnat res;
+  unsigned char b1, b2, b3, b4;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+  b3 = ((unsigned char*) b->data)[idx+2];
+  b4 = ((unsigned char*) b->data)[idx+3];
+#ifdef ARCH_BIG_ENDIAN
+  res = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+#else
+  res = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+  return caml_copy_int32(res);
+}
+
+#ifdef ARCH_INT64_TYPE
+#include "int64_native.h"
+#else
+#include "int64_emul.h"
+#endif
+
+CAMLprim value caml_ba_uint8_get64(value vb, value vind)
+{
+  uint32 reshi;
+  uint32 reslo;
+  unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+  b1 = ((unsigned char*) b->data)[idx];
+  b2 = ((unsigned char*) b->data)[idx+1];
+  b3 = ((unsigned char*) b->data)[idx+2];
+  b4 = ((unsigned char*) b->data)[idx+3];
+  b5 = ((unsigned char*) b->data)[idx+4];
+  b6 = ((unsigned char*) b->data)[idx+5];
+  b7 = ((unsigned char*) b->data)[idx+6];
+  b8 = ((unsigned char*) b->data)[idx+7];
+#ifdef ARCH_BIG_ENDIAN
+  reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4;
+  reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8;
+#else
+  reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5;
+  reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1;
+#endif
+  return caml_copy_int64(I64_literal(reshi,reslo));
+}
+
 /* Generic write to a big array */
 
 static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
@@ -464,6 +526,92 @@ CAMLprim value caml_ba_set_generic(value vb, value vind, value newval)
   return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
 }
 
+CAMLprim value caml_ba_uint8_set16(value vb, value vind, value newval)
+{
+  unsigned char b1, b2;
+  intnat val;
+  intnat idx = Long_val(vind);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 1) caml_array_bound_error();
+  val = Long_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & val >> 8;
+  b2 = 0xFF & val;
+#else
+  b2 = 0xFF & val >> 8;
+  b1 = 0xFF & val;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval)
+{
+  unsigned char b1, b2, b3, b4;
+  intnat idx = Long_val(vind);
+  intnat val;
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error();
+  val = Int32_val(newval);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & val >> 24;
+  b2 = 0xFF & val >> 16;
+  b3 = 0xFF & val >> 8;
+  b4 = 0xFF & val;
+#else
+  b4 = 0xFF & val >> 24;
+  b3 = 0xFF & val >> 16;
+  b2 = 0xFF & val >> 8;
+  b1 = 0xFF & val;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  ((unsigned char*) b->data)[idx+2] = b3;
+  ((unsigned char*) b->data)[idx+3] = b4;
+  return Val_unit;
+}
+
+CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval)
+{
+  unsigned char b1, b2, b3, b4, b5, b6, b7, b8;
+  uint32 lo,hi;
+  intnat idx = Long_val(vind);
+  int64 val;
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error();
+  val = Int64_val(newval);
+  I64_split(val,hi,lo);
+#ifdef ARCH_BIG_ENDIAN
+  b1 = 0xFF & hi >> 24;
+  b2 = 0xFF & hi >> 16;
+  b3 = 0xFF & hi >> 8;
+  b4 = 0xFF & hi;
+  b5 = 0xFF & lo >> 24;
+  b6 = 0xFF & lo >> 16;
+  b7 = 0xFF & lo >> 8;
+  b8 = 0xFF & lo;
+#else
+  b8 = 0xFF & hi >> 24;
+  b7 = 0xFF & hi >> 16;
+  b6 = 0xFF & hi >> 8;
+  b5 = 0xFF & hi;
+  b4 = 0xFF & lo >> 24;
+  b3 = 0xFF & lo >> 16;
+  b2 = 0xFF & lo >> 8;
+  b1 = 0xFF & lo;
+#endif
+  ((unsigned char*) b->data)[idx] = b1;
+  ((unsigned char*) b->data)[idx+1] = b2;
+  ((unsigned char*) b->data)[idx+2] = b3;
+  ((unsigned char*) b->data)[idx+3] = b4;
+  ((unsigned char*) b->data)[idx+4] = b5;
+  ((unsigned char*) b->data)[idx+5] = b6;
+  ((unsigned char*) b->data)[idx+6] = b7;
+  ((unsigned char*) b->data)[idx+7] = b8;
+  return Val_unit;
+}
+
 /* Return the number of dimensions of a big array */
 
 CAMLprim value caml_ba_num_dims(value vb)
@@ -482,6 +630,21 @@ CAMLprim value caml_ba_dim(value vb, value vn)
   return Val_long(b->dim[n]);
 }
 
+CAMLprim value caml_ba_dim_1(value vb)
+{
+  return caml_ba_dim(vb, Val_int(0));
+}
+
+CAMLprim value caml_ba_dim_2(value vb)
+{
+  return caml_ba_dim(vb, Val_int(1));
+}
+
+CAMLprim value caml_ba_dim_3(value vb)
+{
+  return caml_ba_dim(vb, Val_int(2));
+}
+
 /* Return the kind of a big array */
 
 CAMLprim value caml_ba_kind(value vb)
@@ -779,12 +942,7 @@ static void caml_ba_serialize(value v,
   }
   /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
      is exactly 4 + num_dims words */
-  /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
-  Assert(sizeof(struct caml_ba_array) == 4 * sizeof(value));
-#else
-  Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
-#endif
+  Assert(SIZEOF_BA_ARRAY == 4 * sizeof(value));
   *wsize_32 = (4 + b->num_dims) * 4;
   *wsize_64 = (4 + b->num_dims) * 8;
 }
@@ -852,11 +1010,7 @@ uintnat caml_ba_deserialize(void * dst)
     caml_ba_deserialize_longarray(b->data, num_elts); break;
   }
   /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
-  return sizeof(struct caml_ba_array) + b->num_dims * sizeof(intnat);
-#else
-  return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat);
-#endif
+  return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
 }
 
 /* Create / update proxy to indicate that b2 is a sub-array of b1 */
diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
index e208f21f..5ba8cbf6 100644
--- a/otherlibs/bigarray/mmap_unix.c
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mmap_unix.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 /* 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 500
diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
index 00ab152a..4eca668a 100644
--- a/otherlibs/bigarray/mmap_win32.c
+++ b/otherlibs/bigarray/mmap_win32.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mmap_win32.c 12149 2012-02-10 16:15:24Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 1a6b450b..e90aa414 100644
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $
-
 # Makefile for the dynamic link library
 
 include ../../config/Makefile
@@ -20,7 +18,7 @@ include ../../config/Makefile
 CAMLC=../../boot/ocamlrun ../../ocamlc
 CAMLOPT=../../ocamlcompopt.sh
 INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
-COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES)
+COMPFLAGS=-w +33..39 -warn-error A -I ../../stdlib $(INCLUDES)
 
 OBJS=dynlinkaux.cmo dynlink.cmo
 
@@ -47,10 +45,12 @@ all: dynlink.cma extract_crc
 allopt: dynlink.cmxa
 
 dynlink.cma: $(OBJS)
-	$(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS)
+	$(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \
+	         $(OBJS)
 
 dynlink.cmxa: $(NATOBJS)
-	$(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS)
+	$(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \
+	           $(NATOBJS)
 
 dynlinkaux.cmo: $(COMPILEROBJS)
 	$(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS)
diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt
index 1ff250a7..c041c2f7 100644
--- a/otherlibs/dynlink/Makefile.nt
+++ b/otherlibs/dynlink/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the dynamic link library
 
 include Makefile
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index 672a4c49..fee98f1c 100644
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: dynlink.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Dynamic loading of .cmo files *)
 
 open Dynlinkaux  (* REMOVE_ME for ../../debugger/dynlink.ml *)
@@ -36,6 +34,39 @@ type error =
 
 exception Error of error
 
+let () =
+  Printexc.register_printer
+    (function
+      | Error err ->
+          let msg = match err with
+          | Not_a_bytecode_file s ->
+              Printf.sprintf "Not_a_bytecode_file %S" s
+          | Inconsistent_import s ->
+              Printf.sprintf "Inconsistent_import %S" s
+          | Unavailable_unit s ->
+              Printf.sprintf "Unavailable_unit %S" s
+          | Unsafe_file ->
+              "Unsafe_file"
+          | Linking_error (s, Undefined_global s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)"
+                             s s'
+          | Linking_error (s, Unavailable_primitive s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive \
+                              %S)" s s'
+          | Linking_error (s, Uninitialized_global s') ->
+              Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global \
+                              %S)" s s'
+          | Corrupted_interface s ->
+              Printf.sprintf "Corrupted_interface %S" s
+          | File_not_found s ->
+              Printf.sprintf "File_not_found %S" s
+          | Cannot_open_dll s ->
+              Printf.sprintf "Cannot_open_dll %S" s
+          | Inconsistent_implementation s ->
+              Printf.sprintf "Inconsistent_implementation %S" s in
+          Some (Printf.sprintf "Dynlink.Error(Dynlink.%s)" msg)
+      | _ -> None)
+
 (* Management of interface CRCs *)
 
 let crc_interfaces = ref (Consistbl.create ())
@@ -204,7 +235,8 @@ let load_compunit ic file_name file_digest compunit =
 
 let loadfile file_name =
   init();
-  if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name));
+  if not (Sys.file_exists file_name)
+    then raise (Error (File_not_found file_name));
   let ic = open_in_bin file_name in
   let file_digest = Digest.channel ic (-1) in
   seek_in ic 0;
diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
index 914231f1..4ced8760 100644
--- a/otherlibs/dynlink/dynlink.mli
+++ b/otherlibs/dynlink/dynlink.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: dynlink.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Dynamic loading of object files. *)
 
 val is_native: bool
@@ -70,7 +68,7 @@ val default_available_units: unit -> unit
 
 val allow_unsafe_modules : bool -> unit
 (** Govern whether unsafe object files are allowed to be
-    dynamically linked. A compilation unit is ``unsafe'' if it contains
+    dynamically linked. A compilation unit is 'unsafe' if it contains
     declarations of external functions, which can break type safety.
     By default, dynamic linking of unsafe object files is
     not allowed. In native code, this function does nothing; object files
diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
index 1e1fc768..4a6a310a 100644
--- a/otherlibs/dynlink/extract_crc.ml
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: extract_crc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Print the digests of unit interfaces *)
 
 let load_path = ref []
diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index 2eedc8e9..fd06d7c7 100644
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: natdynlink.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Dynamic loading of .cmx files *)
 
 type handle
diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 84c8960d..ab9faa61 100644
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -5,7 +5,7 @@ color.o: color.c libgraph.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h \
-
+ 
 draw.o: draw.c libgraph.h \
   \
   \
diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 92c3dfc8..9586f1c4 100644
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the portable graphics library
 
 LIBNAME=graphics
@@ -28,7 +26,7 @@ EXTRACFLAGS=$(X11_INCLUDES)
 include ../Makefile
 
 depend:
-	gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend
+	gcc -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
 	../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
 
 include .depend
diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
index b31d9241..5b940605 100644
--- a/otherlibs/graph/color.c
+++ b/otherlibs/graph/color.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: color.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include 
 
@@ -99,7 +97,8 @@ void caml_gr_init_direct_rgb_to_pixel(void)
     fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r);
 #endif
     for(i=0; i<256; i++){
-      caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
+      caml_gr_green_vals[i] =
+        (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l;
     }
 
     caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r);
@@ -107,7 +106,8 @@ void caml_gr_init_direct_rgb_to_pixel(void)
     fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r);
 #endif
     for(i=0; i<256; i++){
-      caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
+      caml_gr_blue_vals[i] =
+        (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l;
     }
 
     if( caml_gr_red_l < 0 || caml_gr_red_r < 0 ||
@@ -191,9 +191,12 @@ int caml_gr_rgb_pixel(long unsigned int pixel)
   int i;
 
   if (caml_gr_direct_rgb) {
-    r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) >> (16 - caml_gr_red_r);
-    g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) >> (16 - caml_gr_green_r);
-    b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) >> (16 - caml_gr_blue_r);
+    r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8)
+        >> (16 - caml_gr_red_r);
+    g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8)
+        >> (16 - caml_gr_green_r);
+    b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8)
+        >> (16 - caml_gr_blue_r);
     return (r << 16) + (g << 8) + b;
   }
 
diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c
index d1e46225..dc657875 100644
--- a/otherlibs/graph/draw.c
+++ b/otherlibs/graph/draw.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: draw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include 
 
@@ -22,9 +20,11 @@ value caml_gr_plot(value vx, value vy)
   int y = Int_val(vy);
   caml_gr_check_open();
   if(caml_gr_remember_modeflag)
-    XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y));
+    XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x,
+               Bcvt(y));
   if(caml_gr_display_modeflag) {
-    XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y));
+    XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x,
+               Wcvt(y));
     XFlush(caml_gr_display);
   }
   return Val_unit;
@@ -84,7 +84,8 @@ value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
   return Val_unit;
 }
 
-value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1,
+                           value va2)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
@@ -107,7 +108,8 @@ value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1,
 
 value caml_gr_draw_arc(value *argv, int argc)
 {
-  return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+  return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4],
+                              argv[5]);
 }
 
 value caml_gr_set_line_width(value vwidth)
diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c
index e68db3e8..4ba5c066 100644
--- a/otherlibs/graph/dump_img.c
+++ b/otherlibs/graph/dump_img.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dump_img.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include "image.h"
 #include 
@@ -35,15 +33,18 @@ value caml_gr_dump_image(value image)
     }
 
     idata =
-      XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
+      XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1),
+                ZPixmap);
     for (i = 0; i < height; i++)
       for (j = 0; j < width; j++)
-        Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
+        Field(Field(m, i), j) =
+          Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
     XDestroyImage(idata);
 
     if (Mask_im(image) != None) {
       imask =
-        XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap);
+        XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1,
+                  ZPixmap);
       for (i = 0; i < height; i++)
         for (j = 0; j < width; j++)
           if (XGetPixel(imask, j, i) == 0)
diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index 27c5586e..94bd8bc4 100644
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: events.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "libgraph.h"
 #include 
@@ -62,8 +60,10 @@ void caml_gr_handle_event(XEvent * event)
   switch (event->type) {
 
   case Expose:
-    XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
-              event->xexpose.x, event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h,
+    XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win,
+              caml_gr_window.gc,
+              event->xexpose.x,
+              event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h,
               event->xexpose.width, event->xexpose.height,
               event->xexpose.x, event->xexpose.y);
     XFlush(caml_gr_display);
@@ -72,7 +72,8 @@ void caml_gr_handle_event(XEvent * event)
   case ConfigureNotify:
     caml_gr_window.w = event->xconfigure.width;
     caml_gr_window.h = event->xconfigure.height;
-    if (caml_gr_window.w > caml_gr_bstore.w || caml_gr_window.h > caml_gr_bstore.h) {
+    if (caml_gr_window.w > caml_gr_bstore.w
+        || caml_gr_window.h > caml_gr_bstore.h) {
 
       /* Allocate a new backing store large enough to accomodate
          both the old backing store and the current window. */
@@ -80,7 +81,8 @@ void caml_gr_handle_event(XEvent * event)
       newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w);
       newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h);
       newbstore.win =
-        XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, newbstore.h,
+        XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w,
+                      newbstore.h,
                       XDefaultDepth(caml_gr_display, caml_gr_screen));
       newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL);
       XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white);
@@ -92,8 +94,10 @@ void caml_gr_handle_event(XEvent * event)
         XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid);
 
       /* Copy the old backing store into the new one */
-      XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, newbstore.gc,
-                0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, newbstore.h - caml_gr_bstore.h);
+      XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win,
+                newbstore.gc,
+                0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0,
+                newbstore.h - caml_gr_bstore.h);
 
       /* Free the old backing store */
       XFreeGC(caml_gr_display, caml_gr_bstore.gc);
@@ -155,6 +159,7 @@ static value caml_gr_wait_event_poll(void)
   unsigned int modifiers;
   unsigned int i;
 
+  caml_process_pending_signals ();
   if (XQueryPointer(caml_gr_display, caml_gr_window.win,
                     &rootwin, &childwin,
                     &root_x, &root_y, &win_x, &win_y,
@@ -177,7 +182,8 @@ static value caml_gr_wait_event_poll(void)
       break;
     }
   }
-  return caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
+  return
+    caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key);
 }
 
 static value caml_gr_wait_event_in_queue(long mask)
diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c
index a3422acb..1e2965f1 100644
--- a/otherlibs/graph/fill.c
+++ b/otherlibs/graph/fill.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fill.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include 
 
@@ -42,7 +40,7 @@ value caml_gr_fill_poly(value array)
 
   caml_gr_check_open();
   npoints = Wosize_val(array);
-  points = (XPoint *) stat_alloc(npoints * sizeof(XPoint));
+  points = (XPoint *) caml_stat_alloc(npoints * sizeof(XPoint));
   for (i = 0; i < npoints; i++) {
     points[i].x = Int_val(Field(Field(array, i), 0));
     points[i].y = Bcvt(Int_val(Field(Field(array, i), 1)));
@@ -61,7 +59,8 @@ value caml_gr_fill_poly(value array)
   return Val_unit;
 }
 
-value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2)
+value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1,
+                           value va2)
 {
   int x = Int_val(vx);
   int y = Int_val(vy);
@@ -84,5 +83,6 @@ value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1,
 
 value caml_gr_fill_arc(value *argv, int argc)
 {
-  return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+  return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4],
+                              argv[5]);
 }
diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 32d89c53..441c6760 100644
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphics.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 exception Graphic_failure of string
 
 (* Initializations *)
@@ -214,6 +212,18 @@ let read_key () =
 let key_pressed () =
   let e = wait_next_event [Poll] in e.keypressed
 
+let loop_at_exit events handler =
+  let events = List.filter (fun e -> e <> Poll) events in
+  at_exit (fun _ ->
+    try
+      while true do
+        let e = wait_next_event events in
+        handler e
+      done
+    with Exit -> close_graph ()
+       | e -> close_graph (); raise e
+  )
+
 (*** Sound *)
 
 external sound : int -> int -> unit = "caml_gr_sound"
diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
index c169e657..81cd4eeb 100644
--- a/otherlibs/graph/graphics.mli
+++ b/otherlibs/graph/graphics.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphics.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Machine-independent graphics primitives. *)
 
 exception Graphic_failure of string
@@ -237,7 +235,7 @@ type image
    Externally, images are represented as matrices of colors. *)
 
 val transp : color
-(** In matrices of colors, this color represent a ``transparent''
+(** In matrices of colors, this color represent a 'transparent'
    point: when drawing the corresponding image, all pixels on the
    screen corresponding to a transparent pixel in the image will
    not be modified, while other points will be set to the color
@@ -305,6 +303,14 @@ external wait_next_event : event list -> status = "caml_gr_wait_event"
    are queued, and dequeued one by one when the [Key_pressed]
    event is specified. *)
 
+val loop_at_exit : event list -> (status -> unit) -> unit
+(** Loop before exiting the program, the list given as argument is the
+    list of handlers and the events on which these handlers are called.
+    To exit cleanly the loop, the handler should raise Exit. Any other
+    exception will be propagated outside of the loop.
+    @since 4.01
+*)
+
 (** {6 Mouse and keyboard polling} *)
 
 val mouse_pos : unit -> int * int
@@ -335,7 +341,7 @@ external sound : int -> int -> unit = "caml_gr_sound"
 
 val auto_synchronize : bool -> unit
 (** By default, drawing takes place both on the window displayed
-   on screen, and in a memory area (the ``backing store'').
+   on screen, and in a memory area (the 'backing store').
    The backing store image is used to re-paint the on-screen
    window when necessary.
 
diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml
index 26148f30..33ef1bc9 100644
--- a/otherlibs/graph/graphicsX11.ml
+++ b/otherlibs/graph/graphicsX11.ml
@@ -11,9 +11,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphicsX11.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-(* Module [GraphicsX11]: additional graphics primitives for the X Windows system *)
+(* Module [GraphicsX11]: additional graphics primitives for
+   the X Windows system *)
 
 type window_id = string
 
@@ -37,5 +36,5 @@ let close_subwindow wid =
     close_subwindow wid;
     Hashtbl.remove subwindows wid
   end else
-    raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid))
+    raise (Graphics.Graphic_failure("close_subwindow: no such subwindow: "^wid))
 ;;
diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli
index b6080851..918f9d50 100644
--- a/otherlibs/graph/graphicsX11.mli
+++ b/otherlibs/graph/graphicsX11.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: graphicsX11.mli 12149 2012-02-10 16:15:24Z doligez $ *)
-
 (** Additional graphics primitives for the X Windows system. *)
 
 type window_id = string
diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c
index 522322e3..31693bbd 100644
--- a/otherlibs/graph/image.c
+++ b/otherlibs/graph/image.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: image.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include "image.h"
 #include 
@@ -85,12 +83,14 @@ value caml_gr_draw_image(value im, value vx, value vy)
     }
   }
   if(caml_gr_remember_modeflag)
-    XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, caml_gr_bstore.gc,
+    XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win,
+              caml_gr_bstore.gc,
               0, 0,
               Width_im(im), Height_im(im),
               x, by);
   if(caml_gr_display_modeflag)
-    XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, caml_gr_window.gc,
+    XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win,
+              caml_gr_window.gc,
           0, 0,
           Width_im(im), Height_im(im),
           x, wy);
@@ -104,5 +104,3 @@ value caml_gr_draw_image(value im, value vx, value vy)
     XFlush(caml_gr_display);
   return Val_unit;
 }
-
-/* eof $Id: image.c 11156 2011-07-27 14:17:02Z doligez $ */
diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
index 619121b7..806f1fd2 100644
--- a/otherlibs/graph/image.h
+++ b/otherlibs/graph/image.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: image.h 11156 2011-07-27 14:17:02Z doligez $ */
-
 struct grimage {
   int width, height;            /* Dimensions of the image */
   Pixmap data;                  /* Pixels */
diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
index 9b196602..e75ee801 100644
--- a/otherlibs/graph/libgraph.h
+++ b/otherlibs/graph/libgraph.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: libgraph.h 12149 2012-02-10 16:15:24Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -34,8 +32,8 @@ extern int caml_gr_background;        /* Background color for X
                                      (used for CAML color -1) */
 extern Bool caml_gr_display_modeflag;     /* Display-mode flag */
 extern Bool caml_gr_remember_modeflag;    /* Remember-mode flag */
-extern int caml_gr_x, caml_gr_y;            /* Coordinates of the current point */
-extern int caml_gr_color;             /* Current *CAML* drawing color (can be -1) */
+extern int caml_gr_x, caml_gr_y;      /* Coordinates of the current point */
+extern int caml_gr_color;        /* Current *CAML* drawing color (can be -1) */
 extern XFontStruct * caml_gr_font;    /* Current font */
 extern long caml_gr_selected_events;  /* Events we are interested in */
 extern Bool caml_gr_ignore_sigio;     /* Whether to consume events on sigio */
diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c
index 37dc3ec4..932d4605 100644
--- a/otherlibs/graph/make_img.c
+++ b/otherlibs/graph/make_img.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: make_img.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include "image.h"
 #include 
@@ -38,12 +36,13 @@ value caml_gr_make_image(value m)
 
   /* Build an XImage for the data part of the image */
   idata =
-    XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
+    XCreateImage(caml_gr_display,
+                 DefaultVisual(caml_gr_display, caml_gr_screen),
                  XDefaultDepth(caml_gr_display, caml_gr_screen),
                  ZPixmap, 0, NULL, width, height,
                  BitmapPad(caml_gr_display), 0);
 
-  bdata = (char *) stat_alloc(height * idata->bytes_per_line);
+  bdata = (char *) caml_stat_alloc(height * idata->bytes_per_line);
   idata->data = bdata;
   has_transp = False;
 
@@ -60,10 +59,11 @@ value caml_gr_make_image(value m)
      build an XImage for the mask part of the image */
   if (has_transp) {
     imask =
-      XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen),
+      XCreateImage(caml_gr_display,
+                   DefaultVisual(caml_gr_display, caml_gr_screen),
                    1, ZPixmap, 0, NULL, width, height,
                    BitmapPad(caml_gr_display), 0);
-    bmask = (char *) stat_alloc(height * imask->bytes_per_line);
+    bmask = (char *) caml_stat_alloc(height * imask->bytes_per_line);
     imask->data = bmask;
 
     for (i = 0; i < height; i++) {
@@ -84,9 +84,11 @@ value caml_gr_make_image(value m)
   XDestroyImage(idata);
   XFreeGC(caml_gr_display, gc);
   if (has_transp) {
-    Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, height, 1);
+    Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width,
+                                height, 1);
     gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL);
-    XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height);
+    XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width,
+              height);
     XDestroyImage(imask);
     XFreeGC(caml_gr_display, gc);
   }
diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
index 09720904..e3529d42 100644
--- a/otherlibs/graph/open.c
+++ b/otherlibs/graph/open.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -95,7 +93,8 @@ value caml_gr_open_graph(value arg)
     hints.flags = PPosition | PSize;
     hints.win_gravity = 0;
 
-    ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", BORDER_WIDTH,
+    ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "",
+                      BORDER_WIDTH,
                       &hints, &x, &y, &w, &h, &hints.win_gravity);
     if (ret & (XValue | YValue)) {
       hints.x = x; hints.y = y; hints.flags |= USPosition;
@@ -140,7 +139,8 @@ value caml_gr_open_graph(value arg)
     caml_gr_bstore.w = caml_gr_window.w;
     caml_gr_bstore.h = caml_gr_window.h;
     caml_gr_bstore.win =
-      XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h,
+      XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w,
+                    caml_gr_bstore.h,
                     XDefaultDepth(caml_gr_display, caml_gr_screen));
     caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL);
     XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background);
@@ -213,7 +213,9 @@ value caml_gr_close_graph(void)
     setitimer(ITIMER_REAL, &it, NULL);
 #endif
     caml_gr_initialized = False;
-    if (caml_gr_font != NULL) { XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; }
+    if (caml_gr_font != NULL) {
+      XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL;
+    }
     XFreeGC(caml_gr_display, caml_gr_window.gc);
     XDestroyWindow(caml_gr_display, caml_gr_window.win);
     XFreeGC(caml_gr_display, caml_gr_bstore.gc);
@@ -242,7 +244,7 @@ value caml_gr_window_id(void)
 value caml_gr_set_window_title(value n)
 {
   if (window_name != NULL) stat_free(window_name);
-  window_name = stat_alloc(strlen(String_val(n))+1);
+  window_name = caml_stat_alloc(strlen(String_val(n))+1);
   strcpy(window_name, String_val(n));
   if (caml_gr_initialized) {
     XStoreName(caml_gr_display, caml_gr_window.win, window_name);
@@ -313,7 +315,8 @@ value caml_gr_size_y(void)
 value caml_gr_synchronize(void)
 {
   caml_gr_check_open();
-  XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc,
+  XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win,
+            caml_gr_window.gc,
             0, caml_gr_bstore.h - caml_gr_window.h,
             caml_gr_window.w, caml_gr_window.h,
             0, 0);
@@ -369,7 +372,8 @@ void caml_gr_fail(char *fmt, char *arg)
   if (graphic_failure_exn == NULL) {
     graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
     if (graphic_failure_exn == NULL)
-      invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma");
+      invalid_argument("Exception Graphics.Graphic_failure not initialized,"
+                       " must link graphics.cma");
   }
   sprintf(buffer, fmt, arg);
   raise_with_string(*graphic_failure_exn, buffer);
diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
index c53ab55f..da1e8799 100644
--- a/otherlibs/graph/point_col.c
+++ b/otherlibs/graph/point_col.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: point_col.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 
 value caml_gr_point_color(value vx, value vy)
@@ -23,7 +21,8 @@ value caml_gr_point_color(value vx, value vy)
   int rgb;
 
   caml_gr_check_open();
-  im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap);
+  im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1),
+                 ZPixmap);
   rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0));
   XDestroyImage(im);
   return Val_int(rgb);
diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c
index 8c61f522..4ce11010 100644
--- a/otherlibs/graph/sound.c
+++ b/otherlibs/graph/sound.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sound.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 
 value caml_gr_sound(value vfreq, value vdur)
diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
index 6b305d07..952dccb8 100644
--- a/otherlibs/graph/subwindow.c
+++ b/otherlibs/graph/subwindow.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: subwindow.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 
 value caml_gr_open_subwindow(value vx, value vy, value width, value height)
diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
index 02f5f66f..8ac422d5 100644
--- a/otherlibs/graph/text.c
+++ b/otherlibs/graph/text.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: text.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "libgraph.h"
 #include 
 
@@ -45,10 +43,12 @@ static void caml_gr_draw_text(char *txt, int len)
   if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
   if (caml_gr_remember_modeflag)
     XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc,
-                caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+                caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt,
+                len);
   if (caml_gr_display_modeflag) {
     XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc,
-                caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len);
+                caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt,
+                len);
     XFlush(caml_gr_display);
   }
   caml_gr_x += XTextWidth(caml_gr_font, txt, len);
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile
index e7964bdf..a21973e7 100644
--- a/otherlibs/labltk/browser/Makefile
+++ b/otherlibs/labltk/browser/Makefile
@@ -12,7 +12,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
+# $Id$
 
 OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str
 
diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt
index 40beb5ae..289b0924 100644
--- a/otherlibs/labltk/browser/Makefile.nt
+++ b/otherlibs/labltk/browser/Makefile.nt
@@ -12,7 +12,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
+# $Id$
 
 OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads
 
diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
index 3ab188fa..13736811 100644
--- a/otherlibs/labltk/browser/dummyUnix.mli
+++ b/otherlibs/labltk/browser/dummyUnix.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: dummyUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 module Mutex : sig
   type t
diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli
index dc0271b9..3f8c26e6 100644
--- a/otherlibs/labltk/browser/dummyWin.mli
+++ b/otherlibs/labltk/browser/dummyWin.mli
@@ -12,4 +12,4 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: dummyWin.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index 1ef43123..90241c6b 100644
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: editor.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli
index 0fc4c03d..2d5e9049 100644
--- a/otherlibs/labltk/browser/editor.mli
+++ b/otherlibs/labltk/browser/editor.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: editor.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml
index e13000bf..d62b8ba3 100644
--- a/otherlibs/labltk/browser/fileselect.ml
+++ b/otherlibs/labltk/browser/fileselect.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: fileselect.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* file selection box *)
 
diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli
index 8260eb7b..ed10eaf6 100644
--- a/otherlibs/labltk/browser/fileselect.mli
+++ b/otherlibs/labltk/browser/fileselect.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: fileselect.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val f :
   title:string ->
diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml
index a81c02e0..3fb854b0 100644
--- a/otherlibs/labltk/browser/jg_bind.ml
+++ b/otherlibs/labltk/browser/jg_bind.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_bind.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli
index 100eedef..70e323be 100644
--- a/otherlibs/labltk/browser/jg_bind.mli
+++ b/otherlibs/labltk/browser/jg_bind.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_bind.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml
index e5398d20..bc865f6d 100644
--- a/otherlibs/labltk/browser/jg_box.ml
+++ b/otherlibs/labltk/browser/jg_box.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_box.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml
index 38e64ca2..de8d3582 100644
--- a/otherlibs/labltk/browser/jg_button.ml
+++ b/otherlibs/labltk/browser/jg_button.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_button.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml
index a4273625..a5457a65 100644
--- a/otherlibs/labltk/browser/jg_completion.ml
+++ b/otherlibs/labltk/browser/jg_completion.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_completion.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 let lt_string ?(nocase=false) s1 s2 =
   if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2
diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli
index 165de513..40c2db3c 100644
--- a/otherlibs/labltk/browser/jg_completion.mli
+++ b/otherlibs/labltk/browser/jg_completion.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_completion.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val lt_string : ?nocase:bool -> string -> string -> bool
 
diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml
index d8d3da32..fbbd2ef1 100644
--- a/otherlibs/labltk/browser/jg_config.ml
+++ b/otherlibs/labltk/browser/jg_config.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_config.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Jg_tk
diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli
index 19db0e0c..fdaab3fe 100644
--- a/otherlibs/labltk/browser/jg_config.mli
+++ b/otherlibs/labltk/browser/jg_config.mli
@@ -12,6 +12,6 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_config.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val init: unit -> unit
diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml
index 073f3b84..1f7aab75 100644
--- a/otherlibs/labltk/browser/jg_entry.ml
+++ b/otherlibs/labltk/browser/jg_entry.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_entry.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml
index f180e37d..fb1c05ef 100644
--- a/otherlibs/labltk/browser/jg_memo.ml
+++ b/otherlibs/labltk/browser/jg_memo.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_memo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 type ('a, 'b) assoc_list =
     Nil
diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli
index 34484c16..14443ad1 100644
--- a/otherlibs/labltk/browser/jg_memo.mli
+++ b/otherlibs/labltk/browser/jg_memo.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_memo.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val fast : f:('a -> 'b) -> 'a -> 'b
 (* "fast" memoizer: uses a List.assq like function      *)
diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
index 6bc8b189..880ca775 100644
--- a/otherlibs/labltk/browser/jg_menu.ml
+++ b/otherlibs/labltk/browser/jg_menu.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_menu.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml
index 891f24c9..d4d3ebbd 100644
--- a/otherlibs/labltk/browser/jg_message.ml
+++ b/otherlibs/labltk/browser/jg_message.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_message.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli
index b4af0552..0e123ac2 100644
--- a/otherlibs/labltk/browser/jg_message.mli
+++ b/otherlibs/labltk/browser/jg_message.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_message.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml
index 3e9c5eea..39082e32 100644
--- a/otherlibs/labltk/browser/jg_multibox.ml
+++ b/otherlibs/labltk/browser/jg_multibox.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_multibox.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 
diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli
index 4c280347..bccca506 100644
--- a/otherlibs/labltk/browser/jg_multibox.mli
+++ b/otherlibs/labltk/browser/jg_multibox.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_multibox.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 class c :
   cols:int -> texts:string list ->
diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml
index d2baea04..76eeb92a 100644
--- a/otherlibs/labltk/browser/jg_text.ml
+++ b/otherlibs/labltk/browser/jg_text.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_text.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli
index 33cd858d..44cba023 100644
--- a/otherlibs/labltk/browser/jg_text.mli
+++ b/otherlibs/labltk/browser/jg_text.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_text.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml
index 25d704a6..16106eeb 100644
--- a/otherlibs/labltk/browser/jg_tk.ml
+++ b/otherlibs/labltk/browser/jg_tk.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_tk.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml
index 1e273ac0..d77845df 100644
--- a/otherlibs/labltk/browser/jg_toplevel.ml
+++ b/otherlibs/labltk/browser/jg_toplevel.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: jg_toplevel.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml
index 740f169e..a700f728 100644
--- a/otherlibs/labltk/browser/lexical.ml
+++ b/otherlibs/labltk/browser/lexical.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: lexical.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli
index 5ed79aec..52d09e35 100644
--- a/otherlibs/labltk/browser/lexical.mli
+++ b/otherlibs/labltk/browser/lexical.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: lexical.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml
index 7a72fa1d..4439e741 100644
--- a/otherlibs/labltk/browser/list2.ml
+++ b/otherlibs/labltk/browser/list2.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: list2.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 3ad5ff43..1d79daa5 100644
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 module Unix = UnixLabels
diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli
index b7af747c..217fc111 100644
--- a/otherlibs/labltk/browser/mytypes.mli
+++ b/otherlibs/labltk/browser/mytypes.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: mytypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 834029bd..5450c861 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchid.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
 
 open Asttypes
 open StdLabels
@@ -206,7 +206,7 @@ let mkpath = function
       ~f:(fun acc x -> Pdot (acc, x, 0))
 
 let get_fields ~prefix ~sign self =
-  let env = open_signature (mkpath prefix) sign initial in
+  let env = open_signature Fresh (mkpath prefix) sign initial in
   match (expand_head env self).desc with
     Tobject (ty_obj, _) ->
       let l,_ = flatten_fields ty_obj in l
@@ -294,11 +294,11 @@ let search_string_type text ~mode =
         end in
       try (Typemod.transl_signature env sexp).sig_type
       with Env.Error err -> []
-      | Typemod.Error (l,_) ->
+      | Typemod.Error (l,_,_) ->
           let start_c = l.loc_start.Lexing.pos_cnum in
           let end_c = l.loc_end.Lexing.pos_cnum in
           raise (Error (start_c - 8, end_c - 8))
-      | Typetexp.Error (l,_) ->
+      | Typetexp.Error (l,_,_) ->
           let start_c = l.loc_start.Lexing.pos_cnum in
           let end_c = l.loc_end.Lexing.pos_cnum in
           raise (Error (start_c - 8, end_c - 8))
diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli
index 04b98db4..9e0c8ad9 100644
--- a/otherlibs/labltk/browser/searchid.mli
+++ b/otherlibs/labltk/browser/searchid.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchid.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val start_env : Env.t ref
 val module_list : string list ref
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 30d25a9d..13847e28 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchpos.ml 12681 2012-07-10 08:33:16Z garrigue $ *)
+(* $Id$ *)
 
 open Asttypes
 open StdLabels
@@ -187,10 +187,10 @@ let rec search_pos_signature l ~pos ~env =
   List.fold_left l ~init:env ~f:
   begin fun env pt ->
     let env = match pt.psig_desc with
-      Psig_open id ->
+      Psig_open (ovf, id) ->
         let path, mt = lookup_module id.txt env in
         begin match mt with
-          Mty_signature sign -> open_signature path sign env
+          Mty_signature sign -> open_signature ovf path sign env
         | _ -> env
         end
     | sign_item ->
@@ -220,7 +220,8 @@ let rec search_pos_signature l ~pos ~env =
           List.iter l
             ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
       (* The last cases should not happen in generated interfaces *)
-      | Psig_open lid -> add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc
+      | Psig_open (_, lid) ->
+        add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc
       | Psig_include t -> search_pos_module t ~pos ~env
       end;
     env
@@ -325,7 +326,7 @@ let dummy_item = Sig_modtype (Ident.create "dummy", Modtype_abstract)
 let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
   let env =
     match path with None -> env
-    | Some path -> Env.open_signature path sign env in
+    | Some path -> Env.open_signature Fresh path sign env in
   let title =
     match title, path with Some title, _ -> title
     | None, Some path -> string_of_path path
@@ -385,7 +386,8 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
       tl, tw, finish
   in
   Format.set_max_boxes 100;
-  Printtyp.signature Format.std_formatter sign;
+  Printtyp.wrap_printing_env env
+    (fun () -> Printtyp.signature Format.std_formatter sign);
   finish ();
   Lexical.init_tags tw;
   Lexical.tag tw;
@@ -394,13 +396,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
   let pt =
       try Parse.interface (Lexing.from_string text)
       with Syntaxerr.Error e ->
-        let l =
-          match e with
-            Syntaxerr.Unclosed(l,_,_,_) -> l
-          | Syntaxerr.Applicative_path l -> l
-          | Syntaxerr.Variable_in_scope(l,_) -> l
-          | Syntaxerr.Other l -> l
-        in
+        let l = Syntaxerr.location_of_error e in
         Jg_text.tag_and_see  tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
           ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; []
       | Lexer.Error (_, l) ->
@@ -532,16 +528,18 @@ and view_decl_menu lid ~kind ~env ~parent =
     Format.set_formatter_output_functions buf#out (fun () -> ());
     Format.set_margin 60;
     Format.open_hbox ();
-    if kind = `Type then
-      Printtyp.type_declaration
-        (ident_of_path path ~default:"t")
-        Format.std_formatter
-        (find_type path env)
-    else
-      Printtyp.modtype_declaration
-        (ident_of_path path ~default:"S")
-        Format.std_formatter
-        (find_modtype path env);
+    Printtyp.wrap_printing_env env begin fun () ->
+      if kind = `Type then
+        Printtyp.type_declaration
+          (ident_of_path path ~default:"t")
+          Format.std_formatter
+          (find_type path env)
+      else
+        Printtyp.modtype_declaration
+          (ident_of_path path ~default:"S")
+          Format.std_formatter
+          (find_modtype path env)
+    end;
     Format.close_box (); Format.print_flush ();
     Format.set_formatter_output_functions fo ff;
     Format.set_margin margin;
@@ -632,7 +630,8 @@ let view_type_menu kind ~env ~parent =
       Format.open_hbox ();
       Printtyp.reset ();
       Printtyp.mark_loops ty;
-      Printtyp.type_expr Format.std_formatter ty;
+      Printtyp.wrap_printing_env env
+        (fun () -> Printtyp.type_expr Format.std_formatter ty);
       Format.close_box (); Format.print_flush ();
       Format.set_formatter_output_functions fo ff;
       Format.set_margin margin;
@@ -771,14 +770,14 @@ and search_pos_expr ~pos exp =
         search_pos_expr exp ~pos
       end
   | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
-  | Texp_construct (_, _, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
+  | Texp_construct (_, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
   | Texp_variant (_, None) -> ()
   | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
   | Texp_record (l, opt) ->
-      List.iter l ~f:(fun (_, _, _, exp) -> search_pos_expr exp ~pos);
+      List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos);
       (match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
-  | Texp_field (exp, _, _, _) -> search_pos_expr exp ~pos
-  | Texp_setfield (a, _, _, _, b) ->
+  | Texp_field (exp, _, _) -> search_pos_expr exp ~pos
+  | Texp_setfield (a, _, _, b) ->
       search_pos_expr a ~pos; search_pos_expr b ~pos
   | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
   | Texp_ifthenelse (a, b, c) ->
@@ -836,12 +835,12 @@ and search_pos_pat ~pos ~env pat =
       add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
   | Tpat_tuple l ->
       List.iter l ~f:(search_pos_pat ~pos ~env)
-  | Tpat_construct (_, _, _, l, _) ->
+  | Tpat_construct (_, _, l, _) ->
       List.iter l ~f:(search_pos_pat ~pos ~env)
   | Tpat_variant (_, None, _) -> ()
   | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
   | Tpat_record (l, _) ->
-      List.iter l ~f:(fun (_, _, _, pat) -> search_pos_pat pat ~pos ~env)
+      List.iter l ~f:(fun (_, _, pat) -> search_pos_pat pat ~pos ~env)
   | Tpat_array l ->
       List.iter l ~f:(search_pos_pat ~pos ~env)
   | Tpat_or (a, b, None) ->
diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
index d4a8ed8f..a2d5dfd9 100644
--- a/otherlibs/labltk/browser/searchpos.mli
+++ b/otherlibs/labltk/browser/searchpos.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: searchpos.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml
index beb2fc1a..01865761 100644
--- a/otherlibs/labltk/browser/setpath.ml
+++ b/otherlibs/labltk/browser/setpath.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: setpath.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli
index 875916f0..6191b70c 100644
--- a/otherlibs/labltk/browser/setpath.mli
+++ b/otherlibs/labltk/browser/setpath.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: setpath.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 00e5a856..93525f88 100644
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: shell.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 module Unix = UnixLabels
diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli
index d55954f3..5bb1ff5a 100644
--- a/otherlibs/labltk/browser/shell.mli
+++ b/otherlibs/labltk/browser/shell.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: shell.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 class ['a] history :
   unit ->
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index 6da938d0..286f6bc9 100644
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: typecheck.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
@@ -137,22 +137,17 @@ let f txt =
           Lexer.report_error Format.std_formatter err; l
       | Syntaxerr.Error err ->
           Syntaxerr.report_error Format.std_formatter err;
-          begin match err with
-            Syntaxerr.Unclosed(l,_,_,_) -> l
-          | Syntaxerr.Applicative_path l -> l
-          | Syntaxerr.Variable_in_scope(l,_) -> l
-          | Syntaxerr.Other l -> l
-          end
-      | Typecore.Error (l,err) ->
-          Typecore.report_error Format.std_formatter err; l
-      | Typeclass.Error (l,err) ->
-          Typeclass.report_error Format.std_formatter err; l
+          Syntaxerr.location_of_error err
+      | Typecore.Error (l, env, err) ->
+          Typecore.report_error env Format.std_formatter err; l
+      | Typeclass.Error (l, env, err) ->
+          Typeclass.report_error env Format.std_formatter err; l
       | Typedecl.Error (l, err) ->
           Typedecl.report_error Format.std_formatter err; l
-      | Typemod.Error (l,err) ->
-          Typemod.report_error Format.std_formatter err; l
-      | Typetexp.Error (l,err) ->
-          Typetexp.report_error Format.std_formatter err; l
+      | Typemod.Error (l, env, err) ->
+          Typemod.report_error env Format.std_formatter err; l
+      | Typetexp.Error (l, env, err) ->
+          Typetexp.report_error env Format.std_formatter err; l
       | Includemod.Error errl ->
           Includemod.report_error Format.std_formatter errl; Location.none
       | Env.Error err ->
diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli
index b1dbb9d7..08a16dd2 100644
--- a/otherlibs/labltk/browser/typecheck.mli
+++ b/otherlibs/labltk/browser/typecheck.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: typecheck.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 open Mytypes
diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml
index 02ba237a..86554d48 100644
--- a/otherlibs/labltk/browser/useunix.ml
+++ b/otherlibs/labltk/browser/useunix.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: useunix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open UnixLabels
diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli
index 0f35ce04..47d7a26a 100644
--- a/otherlibs/labltk/browser/useunix.mli
+++ b/otherlibs/labltk/browser/useunix.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: useunix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Unix utilities *)
 
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index 2c67f765..600e4650 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: viewer.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tk
@@ -63,13 +63,13 @@ let view_symbol ~kind ~env ?path id =
       let path, vd = lookup_value id env in
       view_signature_item ~path ~env [Sig_value (Ident.create name, vd)]
   | Ptype -> view_type_id id ~env
-  | Plabel -> let _,ld = lookup_label id env in
+  | Plabel -> let ld = lookup_label id env in
       begin match ld.lbl_res.desc with
         Tconstr (path, _, _) -> view_type_decl path ~env
       | _ -> ()
       end
   | Pconstructor ->
-      let _,cd = lookup_constructor id env in
+      let cd = lookup_constructor id env in
       begin match cd.cstr_res.desc with
         Tconstr (cpath, _, _) ->
         if Path.same cpath Predef.path_exn then
@@ -239,7 +239,7 @@ let view_defined ~env ?(show_all=false) modlid =
     in
     let l = iter_sign sign [] in
     let title = string_of_path path in
-    let env = open_signature path sign env in
+    let env = open_signature Asttypes.Fresh path sign env in
     !choose_symbol_ref l ~title ~signature:sign ~env ~path;
     if show_all then view_signature sign ~title ~env ~path
   | _ -> ()
diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli
index cc188433..c56c5e41 100644
--- a/otherlibs/labltk/browser/viewer.mli
+++ b/otherlibs/labltk/browser/viewer.mli
@@ -12,7 +12,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: viewer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Module viewer *)
 open Widget
diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c
index 8b1691a0..4dd06441 100644
--- a/otherlibs/labltk/browser/winmain.c
+++ b/otherlibs/labltk/browser/winmain.c
@@ -12,7 +12,7 @@
 /*                                                                       */
 /*************************************************************************/
 
-/* $Id: winmain.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE
index ab546d12..dbad5f1c 100644
--- a/otherlibs/labltk/builtin/LICENSE
+++ b/otherlibs/labltk/builtin/LICENSE
@@ -14,6 +14,6 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: LICENSE 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 All the files in this directory are subject to the above copyright notice.
diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile
index 62c22d3a..4a04b953 100644
--- a/otherlibs/labltk/camltk/Makefile
+++ b/otherlibs/labltk/camltk/Makefile
@@ -24,19 +24,17 @@ opt: camltkobjsx
 
 include ./modules
 
-CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo
+CAMLTKOBJS = $(CWIDGETOBJS) cTk.cmo camltk.cmo
 CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx)
 
 camltkobjs: $(CAMLTKOBJS)
 
 camltkobjsx: $(CAMLTKOBJSX)
 
-clean:
-	$(MAKE) -f Makefile.gen clean
-
 install:
 	if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
-	cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
+	cp $(CAMLTKOBJS:.cmo=.cmi) $(INSTALLDIR)
+	cp $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR)
 	chmod 644 $(INSTALLDIR)/*.cmi
 
 installopt:
@@ -44,6 +42,9 @@ installopt:
 	cp $(CAMLTKOBJSX) $(INSTALLDIR)
 	chmod 644 $(INSTALLDIR)/*.cmx
 
+clean:
+	$(MAKE) -f Makefile.gen clean
+
 .SUFFIXES :
 .SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp
 
diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt
index 046b8782..4feb527f 100644
--- a/otherlibs/labltk/camltk/Makefile.gen.nt
+++ b/otherlibs/labltk/camltk/Makefile.gen.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile.gen
diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/camltk/Makefile.nt
+++ b/otherlibs/labltk/camltk/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules
index 723783aa..f9fabdec 100644
--- a/otherlibs/labltk/camltk/modules
+++ b/otherlibs/labltk/camltk/modules
@@ -1,4 +1,4 @@
-CWIDGETOBJS=cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo 
+CWIDGETOBJS= cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
 cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
 
 cBell.cmo : cBell.ml
diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/compiler/Makefile.nt
+++ b/otherlibs/labltk/compiler/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index 9103a859..029cce70 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: compile.ml 12149 2012-02-10 16:15:24Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 open Tables
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 1a8ca90a..42ad1b38 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: intf.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index ec47b6a5..92b14bdb 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -14,13 +14,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mll 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 {
 open StdLabels
 open Lexing
 open Parser
-open Support
 
 exception Lexical_error of string
 let current_line = ref 1
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index 7589fa28..74b144d1 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -14,10 +14,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: maincompile.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
-open Support
 open Tables
 open Printer
 open Compile
@@ -337,8 +336,9 @@ module Timer = Timer;;\n\
   Hashtbl.iter
     (fun name _ ->
       let name = realname name in
+      output_string oc " ";
       output_string oc name;
-      output_string oc ".cmo ")
+      output_string oc ".cmo")
     module_table;
   output_string oc "\n";
   Hashtbl.iter
diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
index e535e91c..6dc7aff3 100644
--- a/otherlibs/labltk/compiler/parser.mly
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: parser.mly 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 %{
 
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
index fe33ada3..e8bfeaa1 100644
--- a/otherlibs/labltk/compiler/printer.ml
+++ b/otherlibs/labltk/compiler/printer.ml
@@ -22,7 +22,7 @@ let escape_string s =
   let more = ref 0 in
   for i = 0 to String.length s - 1 do
    match s.[i] with
-   | '\\' | '"' -> incr more
+   | '\\' | '\"' | '\'' -> incr more
    |  _ -> ()
   done;
   if !more = 0 then s else
@@ -31,45 +31,52 @@ let escape_string s =
   for i = 0 to String.length s - 1 do
    let c = s.[i] in
    match c with
-   | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
+   | '\\' | '\"' |'\'' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j
    | _ -> res.[!j] <- c; incr j
   done;
-  res;;
+  res
+;;
 
-let escape_char c = if c = '\'' then "\\'" else String.make 1 c;;
+let escape_char c = if c = '\'' then "\\\'" else String.make 1 c;;
 
 let print_quoted_string s = printf "\"%s\"" (escape_string s);;
-let print_quoted_char c = printf "'%s'" (escape_char c);;
+let print_quoted_char c = printf "\'%s\'" (escape_char c);;
 let print_quoted_int i =
- if i < 0 then printf "(%d)" i else printf "%d" i;;
+  if i < 0 then printf "(%d)" i else printf "%d" i
+;;
 let print_quoted_float f =
- if f <= 0.0 then printf "(%f)" f else printf "%f" f;;
+  if f <= 0.0 then printf "(%f)" f else printf "%f" f
+;;
 
 (* Iterators *)
 let print_list f l =
- printf "@[<1>[";
- let rec pl = function
- | [] -> printf "@;<0 -1>]@]"
- | [x] -> f x; pl []
- | x :: xs -> f x; printf ";@ "; pl xs in
- pl l;;
+  printf "@[<1>[";
+  let rec pl = function
+  | [] -> printf "@;<0 -1>]@]"
+  | [x] -> f x; pl []
+  | x :: xs -> f x; printf ";@ "; pl xs in
+  pl l
+;;
 
 let print_array f v =
- printf "@[<2>[|";
- let l = Array.length v in
- if l >= 1 then f v.(0);
- if l >= 2 then
-  for i = 1 to l - 1 do
-   printf ";@ "; f v.(i)
-  done;
- printf "@;<0 -1>|]@]";;
+  printf "@[<2>[|";
+  let l = Array.length v in
+  if l >= 1 then f v.(0);
+  if l >= 2 then
+   for i = 1 to l - 1 do
+    printf ";@ "; f v.(i)
+   done;
+  printf "@;<0 -1>|]@]"
+;;
 
 let print_option f = function
   | None -> print_string "None"
-  | Some x -> printf "@[<1>Some@ "; f x; printf "@]";;
+  | Some x -> printf "@[<1>Some@ "; f x; printf "@]"
+;;
 
 let print_bool = function
-  | true -> print_string "true" | _ -> print_string "false";;
+  | true -> print_string "true" | _ -> print_string "false"
+;;
 
 let print_poly x = print_string "";;
 
@@ -97,7 +104,8 @@ let rec print_mltype = function
      printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]"
   | As (m, s) ->
      printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ ";
-     print_quoted_string s; printf ")@]"; printf ")@]";;
+     print_quoted_string s; printf ")@]"; printf ")@]"
+;;
 
 let rec print_template = function
   | StringArg s ->
@@ -111,12 +119,14 @@ let rec print_template = function
   | OptionalArgs (s, l_t, l_t0) ->
      printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>(";
      print_quoted_string s; printf ",@ "; print_list print_template l_t;
-     printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";;
+     printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]"
+;;
 
 (* Sorts of components *)
 let rec print_component_type = function
   | Constructor -> printf "Constructor" | Command -> printf "Command"
-  | External -> printf "External";;
+  | External -> printf "External"
+;;
 
 (* Full definition of a component *)
 let rec print_fullcomponent = function
@@ -128,13 +138,15 @@ let rec print_fullcomponent = function
     printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0;
     printf ";@]@ "; printf "@[<1>template =@ "; print_template t;
     printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ ";
-    printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";;
+    printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]"
+;;
 
 (* components are given either in full or abbreviated *)
 let rec print_component = function
   | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]"
   | Abbrev s ->
-     printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";;
+     printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]"
+;;
 
 (* A type definition *)
 (*
@@ -142,7 +154,8 @@ let rec print_component = function
    an additional argument of type Widget.
 *)
 let rec print_parser_arity = function
-  | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";;
+  | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken"
+;;
 
 let rec print_type_def = function
   {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;
@@ -159,10 +172,12 @@ let rec print_type_def = function
      l_t_s_l_f;
     printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b;
     printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ ";
-    printf "@,}@]";;
+    printf "@,}@]"
+;;
 
 let rec print_module_type = function
-  | Widget -> printf "Widget" | Family -> printf "Family";;
+  | Widget -> printf "Widget" | Family -> printf "Family"
+;;
 
 let rec print_module_def = function
   {module_type = m; commands = l_f; externals = l_f0; } ->
@@ -170,4 +185,5 @@ let rec print_module_def = function
     printf ";@]@ "; printf "@[<1>commands =@ ";
     print_list print_fullcomponent l_f; printf ";@]@ ";
     printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0;
-    printf ";@]@ "; printf "@,}@]";;
+    printf ";@]@ "; printf "@,}@]"
+;;
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index ea8e2181..17025594 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -14,10 +14,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tables.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
-open Support
 
 (* Internal compiler errors *)
 
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index 6084a4d4..6768d0d7 100644
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tsort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 
diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile
index 52de5cd0..a5786b00 100644
--- a/otherlibs/labltk/examples_camltk/Makefile
+++ b/otherlibs/labltk/examples_camltk/Makefile
@@ -1,52 +1,118 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 # We are using the non-installed library !
-COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
+BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
+BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s
+
+WITH_BYT_CAMLTK=labltk.cma camltk.cmo
+WITH_BIN_CAMLTK=labltk.cmxa camltk.cmx
+
+BYT_EXECS =\
+  addition.byt helloworld.byt winskel.byt fileinput.byt\
+  eyes.byt taquin.byt tetris.byt mytext.byt fileopen.byt\
+
+BIN_EXECS=$(BYT_EXECS:.byt=.bin)
+
+EXECS=$(BYT_EXECS:.byt=$(EXE))
+
+all: byt bin
+
+byt: $(BYT_EXECS)
+
+#opt: hello.opt demo.opt calc.opt clock.opt tetris.opt
+
+bin: opt
+
+opt: $(BIN_EXECS)
 
+addition.bin: addition.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) addition.cmx
 
-all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \
-	eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE)
+helloworld.bin: helloworld.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) helloworld.cmx
 
-addition$(EXE): addition.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo
+winskel.bin: winskel.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) winskel.cmx
 
-helloworld$(EXE): helloworld.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo
+fileinput.bin: fileinput.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ $(WITH_BIN_CAMLTK) unix.cmxa fileinput.cmx
 
-winskel$(EXE): winskel.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo
+socketinput.bin: socketinput.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) socketinput.cmx
 
-fileinput$(EXE): fileinput.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo
+eyes.bin: eyes.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) eyes.cmx
 
-socketinput$(EXE): socketinput.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo
+taquin.bin: taquin.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) taquin.cmx
 
-eyes$(EXE): eyes.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo
+tetris.bin: tetris.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) tetris.cmx
 
-tetris$(EXE): tetris.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo
+mytext.bin: mytext.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) mytext.cmx
 
-mytext$(EXE): mytext.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo
+fileopen.bin: fileopen.cmx
+	$(CAMLOPT) $(BIN_COMPFLAGS) -o $@ unix.cmxa $(WITH_BIN_CAMLTK) fileopen.cmx
 
-# graph$(EXE): graphics.cmo graphics_test.cmo
-# 	  $(CAMLC) -o $@ graphics.cmo graphics_test.cmo
-#
-# graphics_test.cmo: graphics.cmo
 
-fileopen$(EXE): fileopen.cmo
-	$(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo
+addition.byt: addition.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo
+
+helloworld.byt: helloworld.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo
+
+winskel.byt: winskel.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo
+
+fileinput.byt: fileinput.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo
+
+socketinput.byt: socketinput.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo
+
+eyes.byt: eyes.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo
+
+taquin.byt: taquin.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma taquin.cmo
+
+tetris.byt: tetris.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo
+
+mytext.byt: mytext.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo
+
+fileopen.byt: fileopen.cmo
+	$(CAMLC) $(BYT_COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo
 
 clean :
-	rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel
+	rm -f *.cm? *.o a.out $(EXECS) $(BYT_EXECS) $(BIN_EXECS)
 
 .SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo
+.SUFFIXES : .mli .ml .cmi .cmo .cmx .cma .cmxa
 
 .mli.cmi:
-	$(CAMLCOMP) $(COMPFLAGS) $<
+	$(CAMLCOMP) $(BYT_COMPFLAGS) -c $<
 
 .ml.cmo:
-	$(CAMLCOMP) $(COMPFLAGS) $<
+	$(CAMLCOMP) $(BYT_COMPFLAGS) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(BIN_COMPFLAGS) -c $<
diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt
index bc6589ca..d84c978c 100644
--- a/otherlibs/labltk/examples_camltk/Makefile.nt
+++ b/otherlibs/labltk/examples_camltk/Makefile.nt
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 # We are using the non-installed library !
diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml
index 44988370..6bebe021 100644
--- a/otherlibs/labltk/examples_camltk/addition.ml
+++ b/otherlibs/labltk/examples_camltk/addition.ml
@@ -13,7 +13,8 @@
 (*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
-open Camltk
+
+open Camltk;;
 
 let main () =
   let top = opentk ()  in
@@ -50,4 +51,5 @@ let main () =
   mainLoop ()
 ;;
 
-let _ = Printexc.catch main () ;;
+Printexc.catch main ()
+;;
diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml
index b7636de4..056b7284 100644
--- a/otherlibs/labltk/examples_camltk/eyes.ml
+++ b/otherlibs/labltk/examples_camltk/eyes.ml
@@ -18,46 +18,57 @@
 
 open Camltk;;
 
-let _ =
-  let top = opentk () in
+let create_eye canvas cx cy wx wy ewx ewy bnd =
+  let _oval2 =
+    Canvas.create_oval canvas
+     (Pixels (cx - wx)) (Pixels (cy - wy))
+     (Pixels (cx + wx)) (Pixels (cy + wy))
+     [Outline (NamedColor "black"); Width (Pixels 7);
+      FillColor (NamedColor "white"); ]
+  and oval =
+    Canvas.create_oval canvas
+     (Pixels (cx - ewx)) (Pixels (cy - ewy))
+     (Pixels (cx + ewx)) (Pixels (cy + ewy))
+     [FillColor (NamedColor "black")] in
+  let curx = ref cx
+  and cury = ref cy in
+
+  let treat_event e =
+
+    let xdiff = e.ev_MouseX - cx
+    and ydiff = e.ev_MouseY - cy in
+
+    let diff =
+      sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
+            (float ydiff /. (float wy *. bnd)) ** 2.0) in
+
+    let nx, ny =
+      if diff <= 1.0 then e.ev_MouseX, e.ev_MouseY else
+        truncate ((float xdiff) *. (1.0 /. diff)) + cx,
+        truncate ((float ydiff) *. (1.0 /. diff)) + cy in
+
+    Canvas.move canvas oval (Pixels (nx - !curx)) (Pixels (ny - !cury));
+    curx := nx;
+    cury := ny; in
+
+  bind canvas [[], Motion] (
+    BindExtend ([Ev_MouseX; Ev_MouseY], treat_event)
+  )
+;;
 
+let main () =
+  let top = opentk () in
   let fw = Frame.create top [] in
   pack [fw] [];
-  let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
-  let create_eye cx cy wx wy ewx ewy bnd =
-    let _o2 =
-       Canvas.create_oval c
-        (Pixels (cx - wx)) (Pixels (cy - wy))
-        (Pixels (cx + wx)) (Pixels (cy + wy))
-        [Outline (NamedColor "black"); Width (Pixels 7);
-         FillColor (NamedColor "white")]
-    and o =
-      Canvas.create_oval c
-       (Pixels (cx - ewx)) (Pixels (cy - ewy))
-       (Pixels (cx + ewx)) (Pixels (cy + ewy))
-       [FillColor (NamedColor "black")] in
-    let curx = ref cx
-    and cury = ref cy in
-    bind c [[], Motion]
-      (BindExtend ([Ev_MouseX; Ev_MouseY],
-        (fun e ->
-          let nx, ny =
-            let xdiff = e.ev_MouseX - cx
-            and ydiff = e.ev_MouseY - cy in
-            let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +.
-                               (float ydiff /. (float wy *. bnd)) ** 2.0) in
-            if diff > 1.0 then
-              truncate ((float xdiff) *. (1.0 /. diff)) + cx,
-              truncate ((float ydiff) *. (1.0 /. diff)) + cy
-            else
-              e.ev_MouseX, e.ev_MouseY
-          in
-          Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury));
-          curx := nx;
-          cury := ny)))
-  in
-  create_eye 60 100 30 40 5 6 0.6;
-  create_eye 140 100 30 40 5 6 0.6;
-  pack [c] []
-
-let _ = Printexc.print mainLoop ()
+
+  let canvas = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
+
+  create_eye canvas 60 100 30 40 5 6 0.6;
+  create_eye canvas 140 100 30 40 5 6 0.6;
+  pack [canvas] [];
+
+  mainLoop ();
+;;
+
+Printexc.print main ();;
+
diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml
index 9829fca8..c90d7bd6 100644
--- a/otherlibs/labltk/examples_camltk/helloworld.ml
+++ b/otherlibs/labltk/examples_camltk/helloworld.ml
@@ -13,25 +13,38 @@
 (*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
-open Camltk;;            (* Make interface functions available *)
 
-let top = opentk ();;   (* Initialisation of the interface *)
-(* top is now the toplevel widget *)
+(* Make interface functions available *)
+open Camltk;;
+
+(* Initialisation of the interface. *)
+let top = opentk ();;
+(* top is now the toplevel widget. *)
 
 (* Widget initialisation *)
-let b = Button.create top
-          [Text "foobar";
-           Command (function () ->
-                      print_string "foobar";
-                      print_newline();
-                      flush stdout)];;
-(* b exists but is not yet visible *)
+let b =
+  Button.create top [
+    Text "foobar";
+    Command
+      (function () ->
+       print_string "foobar";
+       print_newline ();
+       flush stdout);
+  ]
+;;
+(* Now button [b] exists but is not yet visible. *)
+
+let q =
+  Button.create top [
+    Text "quit";
+    Command closeTk;
+  ]
+;;
+(* Button [q] also exists but is not yet visible. *)
 
-let q = Button.create top
-          [Text "quit";
-           Command closeTk];;
-(* q exists but is not yet visible *)
+(* Make b and q visible. *)
+pack [b; q] [];;
 
-pack [b; q][] ;;           (* Make b visible *)
-mainLoop() ;;           (* User interaction*)
-(* You can quit this program by deleting its main window *)
+(* Start user interaction. *)
+mainLoop ();;
+(* You can also quit this program by deleting its main window. *)
diff --git a/otherlibs/labltk/examples_camltk/taquin.ml b/otherlibs/labltk/examples_camltk/taquin.ml
new file mode 100644
index 00000000..70ac934c
--- /dev/null
+++ b/otherlibs/labltk/examples_camltk/taquin.ml
@@ -0,0 +1,146 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                        Caml examples                                *)
+(*                                                                     *)
+(*            Pierre Weis                                              *)
+(*                                                                     *)
+(*                        INRIA Rocquencourt                           *)
+(*                                                                     *)
+(*  Copyright (c) 1994-2011, INRIA                                     *)
+(*  All rights reserved.                                               *)
+(*                                                                     *)
+(*  Distributed under the BSD license.                                 *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: taquin.ml,v 1.4 2011-08-08 19:31:17 weis Exp $ *)
+
+open Camltk;;
+
+let découpe_image img nx ny =
+  let l = Imagephoto.width img
+  and h = Imagephoto.height img in
+  let tx = l / nx and ty = h / ny in
+  let pièces = ref [] in
+  for x = 0 to nx - 1 do
+    for y = 0 to ny - 1 do
+      let pièce =
+        Imagephoto.create [Width (Pixels tx); Height (Pixels ty)] in
+      Imagephoto.copy pièce img
+        [ImgFrom(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty)];
+      pièces := pièce :: !pièces
+    done
+  done;
+  (tx, ty, List.tl !pièces)
+;;
+
+let remplir_taquin c nx ny tx ty pièces =
+  let trou_x = ref (nx - 1)
+  and trou_y = ref (ny - 1) in
+  let trou =
+    Canvas.create_rectangle c
+      (Pixels (!trou_x * tx)) (Pixels (!trou_y * ty))
+      (Pixels tx) (Pixels ty) [] in
+  let taquin = Array.make_matrix nx ny trou in
+  let p = ref pièces in
+  for x = 0 to nx - 1 do
+    for y = 0 to ny - 1 do
+      match !p with
+      | [] -> ()
+      | pièce :: reste ->
+          taquin.(x).(y) <-
+            Canvas.create_image c
+              (Pixels (x * tx)) (Pixels (y * ty))
+              [ImagePhoto pièce; Anchor NW; Tags [Tag "pièce"]];
+          p := reste
+    done
+  done;
+  let déplacer x y =
+    let pièce = taquin.(x).(y) in
+    Canvas.coords_set c pièce
+      [Pixels (!trou_x * tx); Pixels(!trou_y * ty)];
+    Canvas.coords_set c trou
+      [Pixels (x * tx); Pixels(y * ty); Pixels tx; Pixels ty];
+    taquin.(!trou_x).(!trou_y) <- pièce;
+    taquin.(x).(y) <- trou;
+    trou_x := x; trou_y := y in
+  let jouer ei =
+    let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in
+    if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1)
+    || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1)
+    then déplacer x y in
+  Canvas.bind c (Tag "pièce") [[], ButtonPress]
+                (BindSet ([Ev_MouseX; Ev_MouseY], jouer));;
+
+let rec permutation = function
+  | [] -> []
+  | l  -> let n = Random.int (List.length l) in
+          let (élément, reste) = partage l n in
+          élément :: permutation reste
+
+and partage l n =
+  match l with
+  | [] -> failwith "partage"
+  | tête :: reste ->
+      if n = 0 then (tête, reste) else
+      let (élément, reste') = partage reste (n - 1) in
+      (élément, tête :: reste')
+;;
+
+let create_filled_text parent lines =
+  let lnum = List.length lines
+  and lwidth =
+    List.fold_right
+     (fun line max ->
+       let l = String.length line in
+       if l > max then l else max)
+     lines 1 in
+  let txtw = Text.create parent [TextWidth lwidth; TextHeight lnum] in
+  List.iter
+   (fun line ->
+     Text.insert txtw (TextIndex (End, [])) line [];
+     Text.insert txtw (TextIndex (End, [])) "\n" [])
+   lines;
+  txtw
+;;
+
+let give_help parent lines () =
+ let help_window = Toplevel.create parent [] in
+ Wm.title_set help_window "Help";
+
+ let help_frame = Frame.create help_window [] in
+
+ let help_txtw = create_filled_text help_frame lines in
+
+ let quit_help () = destroy help_window in
+ let ok_button = Button.create help_frame [Text "Ok"; Command quit_help] in
+
+ pack [help_txtw; ok_button ] [Side Side_Bottom];
+ pack [help_frame] []
+;;
+
+let taquin nom_fichier nx ny =
+  let fp = openTk () in
+  Wm.title_set fp "Taquin";
+  let img = Imagephoto.create [File nom_fichier] in
+  let c =
+    Canvas.create fp
+     [Width(Pixels(Imagephoto.width img));
+      Height(Pixels(Imagephoto.height img))] in
+  let (tx, ty, pièces) = découpe_image img nx ny in
+  remplir_taquin c nx ny tx ty (permutation pièces);
+  pack [c] [];
+
+  let quit = Button.create fp [Text "Quit"; Command closeTk] in
+  let help_lines =
+   ["Pour jouer, cliquer sur une des pièces";
+    "entourant le trou";
+    "";
+    "To play, click on a part around the hole"] in
+  let help =
+    Button.create fp [Text "Help"; Command (give_help fp help_lines)] in
+  pack [quit; help] [Side Side_Left; Fill Fill_X];
+  mainLoop ()
+;;
+
+if !Sys.interactive then () else begin taquin "joconde.gif" 3 5; exit 0 end;;
diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml
index 14a9b648..a46de602 100644
--- a/otherlibs/labltk/examples_camltk/tetris.ml
+++ b/otherlibs/labltk/examples_camltk/tetris.ml
@@ -1,236 +1,136 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of OCaml                     *)
+(*                        Caml examples                                *)
 (*                                                                     *)
-(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
-(*               projet Cristal, INRIA Rocquencourt                    *)
-(*            Jacques Garrigue, Kyoto University RIMS                  *)
+(*            Pierre Weis                                              *)
 (*                                                                     *)
-(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
-(*  en Automatique and Kyoto University.  All rights reserved.         *)
-(*  This file is distributed under the terms of the GNU Library        *)
-(*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the OCaml source tree.          *)
+(*                        INRIA Rocquencourt                           *)
+(*                                                                     *)
+(*  Copyright (c) 1994-2011, INRIA                                     *)
+(*  All rights reserved.                                               *)
+(*                                                                     *)
+(*  Distributed under the BSD license.                                 *)
 (*                                                                     *)
 (***********************************************************************)
 
-(* A Tetris game for CamlTk *)
-(* written by Jun P. Furuse *)
+(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
 
-open Camltk
+(* A Tetris game for CamlTk.
+   Written by Jun P. Furuse.
+   Adapted to the oc examples repository by P. Weis *)
 
-exception Done
+open Camltk;;
 
-type cell = {mutable color : int;
-             tag : tagOrId * tagOrId * tagOrId}
+(* The directory where images will be found. *)
+let baseurl = "images/";;
+
+exception Done;;
+
+type cell = {
+ mutable color : int;
+ tag : tagOrId * tagOrId * tagOrId;
+}
+;;
 
 type falling_block = {
-  mutable pattern: int array list;
-  mutable bcolor: int;
-  mutable x: int;
-  mutable y: int;
-  mutable d: int;
-  mutable alive: bool
+  mutable pattern : int array list;
+  mutable bcolor : int;
+  mutable x : int;
+  mutable y : int;
+  mutable d : int;
+  mutable alive: bool;
 }
+;;
 
-let stop_a_bit = 300
+let stop_a_bit = 300;;
 
 let colors = [|
-  NamedColor "red";
-  NamedColor "yellow";
-
-  NamedColor "blue";
-  NamedColor "orange";
-
-  NamedColor "magenta";
-  NamedColor "green";
-
-  NamedColor "cyan"
+  NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
+  NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
+  NamedColor "cyan";
 |]
-
-let baseurl = "images/"
+;;
 
 let backgrounds =
   List.map (fun s -> baseurl ^ s)
-    [ "dojoji.back.gif";
-      "Lambda2back.gif";
-      "CamlBook.gif";
-    ]
+    [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
 
 (* blocks *)
 let block_size = 16
-let cell_border = 2
+and cell_border = 2
+;;
 
 let blocks = [
-  [ [|"0000";
-      "0000";
-      "1111";
-      "0000" |];
-
-    [|"0010";
-      "0010";
-      "0010";
-      "0010" |];
-
-    [|"0000";
-      "0000";
-      "1111";
-      "0000" |];
-
-    [|"0010";
-      "0010";
-      "0010";
-      "0010" |] ];
-
-  [ [|"0000";
-      "0110";
-      "0110";
-      "0000" |];
-
-    [|"0000";
-      "0110";
-      "0110";
-      "0000" |];
-
-    [|"0000";
-      "0110";
-      "0110";
-      "0000" |];
-
-    [|"0000";
-      "0110";
-      "0110";
-      "0000" |] ];
-
-  [ [|"0000";
-      "0111";
-      "0100";
-      "0000" |];
-
-    [|"0000";
-      "0110";
-      "0010";
-      "0010" |];
-
-    [|"0000";
-      "0010";
-      "1110";
-      "0000" |];
-
-    [|"0100";
-      "0100";
-      "0110";
-      "0000" |] ];
-
-  [ [|"0000";
-      "0100";
-      "0111";
-      "0000" |];
-
-    [|"0000";
-      "0110";
-      "0100";
-      "0100" |];
-
-    [|"0000";
-      "1110";
-      "0010";
-      "0000" |];
-
-    [|"0010";
-      "0010";
-      "0110";
-      "0000" |] ];
-
-  [ [|"0000";
-      "1100";
-      "0110";
-      "0000" |];
-
-    [|"0010";
-      "0110";
-      "0100";
-      "0000" |];
-
-    [|"0000";
-      "1100";
-      "0110";
-      "0000" |];
-
-    [|"0010";
-      "0110";
-      "0100";
-      "0000" |] ];
-
-  [ [|"0000";
-      "0011";
-      "0110";
-      "0000" |];
-
-    [|"0100";
-      "0110";
-      "0010";
-      "0000" |];
-
-    [|"0000";
-      "0011";
-      "0110";
-      "0000" |];
-
-    [|"0000";
-      "0100";
-      "0110";
-      "0010" |] ];
-
-  [ [|"0000";
-      "0000";
-      "1110";
-      "0100" |];
-
-    [|"0000";
-      "0100";
-      "1100";
-      "0100" |];
-
-    [|"0000";
-      "0100";
-      "1110";
-      "0000" |];
-
-    [|"0000";
-      "0100";
-      "0110";
-      "0100" |] ]
-
+  [ [|"0000"; "0000"; "1111"; "0000" |];
+    [|"0010"; "0010"; "0010"; "0010" |];
+    [|"0000"; "0000"; "1111"; "0000" |];
+    [|"0010"; "0010"; "0010"; "0010" |] ];
+
+  [ [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "0111"; "0100"; "0000" |];
+    [|"0000"; "0110"; "0010"; "0010" |];
+    [|"0000"; "0010"; "1110"; "0000" |];
+    [|"0100"; "0100"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "0100"; "0111"; "0000" |];
+    [|"0000"; "0110"; "0100"; "0100" |];
+    [|"0000"; "1110"; "0010"; "0000" |];
+    [|"0010"; "0010"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "1100"; "0110"; "0000" |];
+    [|"0010"; "0110"; "0100"; "0000" |];
+    [|"0000"; "1100"; "0110"; "0000" |];
+    [|"0010"; "0110"; "0100"; "0000" |] ];
+
+  [ [|"0000"; "0011"; "0110"; "0000" |];
+    [|"0100"; "0110"; "0010"; "0000" |];
+    [|"0000"; "0011"; "0110"; "0000" |];
+    [|"0000"; "0100"; "0110"; "0010" |] ];
+
+  [ [|"0000"; "0000"; "1110"; "0100" |];
+    [|"0000"; "0100"; "1100"; "0100" |];
+    [|"0000"; "0100"; "1110"; "0000" |];
+    [|"0000"; "0100"; "0110"; "0100" |] ];
 ]
+;;
 
 let line_empty = int_of_string "0b1110000000000111"
-let line_full = int_of_string  "0b1111111111111111"
+and line_full = int_of_string  "0b1111111111111111"
+;;
 
 let decode_block dvec =
-  let btoi d = int_of_string ("0b"^d) in
+  let btoi d = int_of_string ("0b" ^ d) in
   Array.map btoi dvec
+;;
 
 let init fw =
   let scorev = Textvariable.create ()
   and linev = Textvariable.create ()
   and levv = Textvariable.create ()
-  in
+  and _namev = Textvariable.create () in
   let f = Frame.create fw [BorderWidth (Pixels 2)] in
-  let c = Canvas.create f [Width (Pixels (block_size * 10));
-                           Height (Pixels (block_size * 20));
-                           BorderWidth (Pixels cell_border);
-                           Relief Sunken;
-                           Background Black]
+  let c =
+    Canvas.create f
+     [Width (Pixels (block_size * 10));
+      Height (Pixels (block_size * 20));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black]
   and r = Frame.create f []
   and r' = Frame.create f [] in
 
   let nl = Label.create r [Text "Next"; Font "variable"] in
-  let nc = Canvas.create r [Width (Pixels (block_size * 4));
-                           Height (Pixels (block_size * 4));
-                           BorderWidth (Pixels cell_border);
-                           Relief Sunken;
-                           Background Black] in
+  let nc =
+    Canvas.create r
+     [Width (Pixels (block_size * 4));
+      Height (Pixels (block_size * 4));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black] in
   let scl = Label.create r [Text "Score"; Font "variable"] in
   let sc = Label.create r [TextVariable scorev; Font "variable"] in
   let lnl = Label.create r [Text "Lines"; Font "variable"] in
@@ -245,139 +145,128 @@ let init fw =
   pack [nl; nc] [Side Side_Top];
   pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
 
-  let cells_src = Array.create 20 (Array.create 10 ()) in
+  let cells_src = Array.make_matrix 20 10 () in
   let cells = Array.map (Array.map (fun () ->
-    {tag=
-        (let t1, t2, t3 =
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle c
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
           Canvas.create_rectangle c
-             (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
-             (Pixels (-9))          (Pixels (-9)) [],
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
           Canvas.create_rectangle c
-             (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
-             (Pixels (-11))          (Pixels (-11)) [],
-          Canvas.create_rectangle c
-             (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
-             (Pixels (-13))          (Pixels (-13)) []
-        in
-          Canvas.raise_top c t1;
-          Canvas.raise_top c t2;
-          Canvas.lower_bot c t3;
-          t1,t2,t3);
-     color= 0})) cells_src
-  in
-  let nexts_src = Array.create 4 (Array.create 4 ()) in
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top c t1;
+       Canvas.raise_top c t2;
+       Canvas.lower_bot c t3;
+       t1, t2, t3);
+     color = 0})) cells_src in
+  let nexts_src = Array.make_matrix 4 4 () in
   let nexts =
    Array.map (Array.map (fun () ->
-    {tag=
-       (let t1, t2, t3 =
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
-             (Pixels (-9))          (Pixels (-9)) [],
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
-             (Pixels (-11))          (Pixels (-11)) [],
-          Canvas.create_rectangle nc
-             (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
-             (Pixels (-13))          (Pixels (-13)) []
-        in
-          Canvas.raise_top nc t1;
-          Canvas.raise_top nc t2;
-          Canvas.lower_bot nc t3;
-          t1, t2, t3);
-     color= 0})) nexts_src in
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top nc t1;
+       Canvas.raise_top nc t2;
+       Canvas.lower_bot nc t3;
+       t1, t2, t3);
+     color = 0})) nexts_src in
   let game_over () = ()
   in
-    [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
-      (c, cells), (nc, nexts), scorev, linev, levv, game_over
+  [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
+  (c, cells), (nc, nexts), scorev, linev, levv, game_over
+;;
 
-let cell_get (c, cf) x y =
-  (Array.get (Array.get cf y) x).color
+let cell_get (c, cf) x y = cf.(y).(x).color;;
 
 let cell_set (c, cf) x y col =
-  let cur = Array.get (Array.get cf y) x in
-  let t1,t2,t3 = cur.tag in
-    if cur.color = col then ()
-    else
-    if cur.color <> 0 && col = 0 then
-      begin
+  let cur = cf.(y).(x) in
+  let t1, t2, t3 = cur.tag in
+  if cur.color = col then () else
+  if cur.color <> 0 && col = 0 then begin
+    Canvas.move c t1
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t2
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t3
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
+
+  end else begin
+    Canvas.configure_rectangle c t2
+      [FillColor (Array.get colors (col - 1));
+       Outline (Array.get colors (col - 1))];
+    Canvas.configure_rectangle c t1
+      [FillColor Black;
+       Outline Black];
+    Canvas.configure_rectangle c t3
+      [FillColor (NamedColor "light gray");
+       Outline (NamedColor "light gray")];
+    if cur.color = 0 && col <> 0 then begin
       Canvas.move c t1
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
       Canvas.move c t2
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
       Canvas.move c t3
-                       (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
-                       (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
-      end
-    else
-      begin
-        Canvas.configure_rectangle c t2
-              [FillColor (Array.get colors (col - 1));
-               Outline (Array.get colors (col - 1))];
-        Canvas.configure_rectangle c t1
-              [FillColor Black;
-               Outline Black];
-        Canvas.configure_rectangle c t3
-              [FillColor (NamedColor "light gray");
-               Outline (NamedColor "light gray")];
-        if cur.color = 0 && col <> 0 then
-          begin
-            Canvas.move c t1
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2));
-            Canvas.move c t2
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2));
-            Canvas.move c t3
-              (Pixels (block_size * (x+1)+10+ cell_border*2))
-              (Pixels (block_size * (y+1)+10+ cell_border*2))
-          end
-      end;
-    cur.color <- col
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2))
+    end
+  end;
+  cur.color <- col
+;;
 
 let draw_block field col d x y =
   for iy = 0 to 3 do
     let base = ref 1 in
     let xd = Array.get d iy in
     for ix = 0 to 3 do
-      if xd land !base <> 0 then
-        begin
-          try cell_set field (ix + x) (iy + y) col with _ -> ()
-        end
-      else
-        begin
-        (* cell_set field (ix + x) (iy + y) 0 *) ()
-        end;
+      if xd land !base <> 0 then begin
+        try cell_set field (ix + x) (iy + y) col with _ -> ()
+      end;
       base := !base lsl 1
     done
   done
+;;
 
-let timer_ref = (ref None : Timer.t option ref)
-(* I know, this should be timer ref, but I'm not sure what should be
-   the initial value ... *)
+let timer_ref = (ref None : Timer.t option ref);;
 
 let remove_timer () =
   match !timer_ref with
   | None -> ()
-  | Some t -> Timer.remove t (* ; prerr_endline "removed!" *)
+  | Some t -> Timer.remove t
+;;
 
-let do_after milli f =
-  timer_ref := Some (Timer.add milli f)
+let do_after milli f = timer_ref := Some (Timer.add milli f);;
 
 let copy_block c =
-  { pattern= !c.pattern;
-    bcolor= !c.bcolor;
-    x= !c.x;
-    y= !c.y;
-    d= !c.d;
-    alive= !c.alive }
-
-let _ =
-  let top = opentk () in
+  { pattern = !c.pattern;
+    bcolor = !c.bcolor;
+    x = !c.x;
+    y = !c.y;
+    d = !c.d;
+    alive = !c.alive }
+;;
+
+let start_game () =
+  let top = openTk () in
+  Wm.title_set top "";
   let lb = Label.create top []
-  and fw = Frame.create top []
-  in
+  and fw = Frame.create top [] in
   let set_message s = Label.configure lb [Text s] in
   pack [lb; fw] [Side Side_Top];
   let score = ref 0 in
@@ -385,10 +274,9 @@ let _ =
   let level = ref 0 in
   let time = ref 1000 in
   let blocks = List.map (List.map decode_block) blocks in
-  let field = Array.create 26 0 in
+  let field = Array.make 26 0 in
   let widgets, newg, exitg, cell_field, next_field,
-      scorev, linev, levv, game_over =
-        init fw in
+      scorev, linev, levv, game_over = init fw in
   let canvas = fst cell_field in
 
   let init_field () =
@@ -405,46 +293,37 @@ let _ =
       for j = 0 to 3 do
         cell_set next_field j i 0
       done
-    done
-  in
+    done in
 
   let draw_falling_block fb =
     draw_block cell_field fb.bcolor
       (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-
   and erase_falling_block fb =
-    draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
-  in
+    draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in
 
   let stone fb =
-    for i=0 to 3 do
+    for i = 0 to 3 do
       let cur = field.(i + fb.y) in
       field.(i + fb.y) <-
          cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
     done;
-    for i=0 to 2 do
-      field.(i) <- line_empty
-    done
+    for i = 0 to 2 do field.(i) <- line_empty done
 
   and clear fb =
     let l = ref 0 in
     for i = 0 to 3 do
-      if i + fb.y >= 3 && i + fb.y <= 22 then
-        if field.(i + fb.y) = line_full then
-          begin
-            incr l;
-            field.(i + fb.y) <- line_empty;
-            for j = 0 to 9 do
-              cell_set cell_field j (i + fb.y - 3) 0
-            done
-          end
+      if i + fb.y >= 3 && i + fb.y <= 22 &&
+         field.(i + fb.y) = line_full then begin
+        incr l;
+        field.(i + fb.y) <- line_empty;
+        for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done
+      end
     done;
     !l
 
   and fall_lines () =
     let eye = ref 22 (* bottom *)
-    and cur = ref 22 (* bottom *)
-    in
+    and cur = ref 22 (* bottom *) in
     try
       while !eye >= 3 do
         while field.(!eye) = line_empty do
@@ -461,33 +340,28 @@ let _ =
     with Done -> ();
       for i = 3 to !cur do
         field.(i) <- line_empty;
-        for j = 0 to 9 do
-          cell_set cell_field j (i-3) 0
-        done
-      done
- in
+        for j = 0 to 9 do cell_set cell_field j (i - 3) 0 done
+      done in
 
   let next = ref 42 (* THE ANSWER *)
   and current =
-    ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false}
-  in
+    ref { pattern= [[|0; 0; 0; 0|]];
+          bcolor = 0; x = 0; y = 0; d = 0; alive = false} in
 
   let draw_next () =
-    draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0
+    draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0
 
   and erase_next () =
-    draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0
-  in
+    draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in
 
   let set_nextblock () =
     current :=
-       { pattern= (List.nth blocks !next);
-         bcolor= !next+1;
-         x=6; y= 1; d= 0; alive= true};
+       { pattern = (List.nth blocks !next);
+         bcolor = !next + 1;
+         x = 6; y = 1; d = 0; alive = true};
     erase_next ();
     next := Random.int 7;
-    draw_next ()
-  in
+    draw_next () in
 
   let death_check fb =
     try
@@ -498,8 +372,7 @@ let _ =
       done;
       false
     with
-      Done -> true
-  in
+      Done -> true in
 
   let try_to_move m =
     if !current.alive then
@@ -511,40 +384,29 @@ let _ =
             draw_falling_block m;
             current := m;
             true
-          end
-      in
-      if sub m then ()
-      else
-        begin
-          m.x <- m.x + 1;
-          if sub m then ()
-          else
-            begin
-              m.x <- m.x - 2;
-              ignore (sub m)
-            end
+          end in
+      if sub m then () else begin
+        m.x <- m.x + 1;
+        if sub m then () else begin
+          m.x <- m.x - 2;
+          ignore (sub m)
         end
-    else ()
-  in
+      end
+    else () in
 
   let image_load =
-    let i = Canvas.create_image canvas
-            (Pixels (block_size * 5 + block_size / 2))
-            (Pixels (block_size * 10 + block_size / 2))
-                [Anchor Center] in
+    let i =
+      Canvas.create_image canvas
+        (Pixels (block_size * 5 + block_size / 2))
+        (Pixels (block_size * 10 + block_size / 2))
+        [Anchor Center] in
     Canvas.lower_bot canvas i;
     let img = Imagephoto.create [] in
     fun file ->
       try
         Imagephoto.configure img [File file];
         Canvas.configure_image canvas i [ImagePhoto img]
-      with
-        _ ->
-          begin
-            Printf.eprintf "%s : No such image...\n" file;
-            flush stderr
-          end
-  in
+      with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in
 
   let add_score l =
     let pline = !line in
@@ -557,62 +419,53 @@ let _ =
     Textvariable.set linev (string_of_int !line);
     Textvariable.set scorev (string_of_int !score);
 
-    if !line /10 <> pline /10 then
+    if !line / 10 <> pline / 10 then
       (* update the background every 10 lines. *)
       begin
         let num_image = List.length backgrounds - 1 in
-        let n = !line/10 in
+        let n = !line / 10 in
         let n = if n > num_image then num_image else n in
         let file = List.nth backgrounds n in
         image_load file;
         (* Future work: We should gain level after an image is put... *)
         incr level;
         Textvariable.set levv (string_of_int !level)
-      end
-  in
+      end in
 
   let rec newblock () =
     set_message "TETRIS";
     set_nextblock ();
     draw_falling_block !current;
-    if death_check !current then
-      begin
+    if death_check !current then begin
         !current.alive <- false;
         set_message "GAME OVER";
         game_over ()
-      end
-    else
-      begin
-        time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
-        if !time < 60 - !level * 3 then time := 60 - !level * 3;
-        do_after stop_a_bit loop
-      end
+    end else begin
+      time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
+      if !time < 60 - !level * 3 then time := 60 - !level * 3;
+      do_after stop_a_bit loop
+    end
 
   and loop () =
     let m = copy_block current in
     m.y <- m.y + 1;
-    if death_check m then
-      begin
-        !current.alive <- false;
-        stone !current;
-        do_after stop_a_bit (fun () ->
-          let l = clear !current in
-            if l > 0 then
-              do_after stop_a_bit (fun () ->
-                fall_lines ();
-                add_score l;
-                do_after stop_a_bit newblock)
-            else
-              newblock ())
-      end
-    else
-      begin
-        erase_falling_block !current;
-        draw_falling_block m;
-        current := m;
-        do_after !time loop
-      end
-  in
+    if death_check m then begin
+      !current.alive <- false;
+      stone !current;
+      do_after stop_a_bit (fun () ->
+        let l = clear !current in
+        if l > 0 then
+          do_after stop_a_bit (fun () ->
+            fall_lines ();
+            add_score l;
+            do_after stop_a_bit newblock)
+        else newblock ())
+    end else begin
+      erase_falling_block !current;
+      draw_falling_block m;
+      current := m;
+      do_after !time loop
+    end in
 
   let bind_game w =
     bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
@@ -656,8 +509,7 @@ let _ =
                 loop ()
               end
         | _ -> ()
-      ))
-  in
+      )) in
 
   let game_init () =
     (* Game Initialization *)
@@ -674,11 +526,17 @@ let _ =
     set_message "Welcome to TETRIS";
     set_nextblock ();
     draw_falling_block !current;
-    do_after !time loop
-  in
-   bind_game top;
-   Button.configure newg [Command game_init];
-   Button.configure exitg [Command (fun () -> closeTk (); exit 0)];
-   game_init ()
+    do_after !time loop in
+
+  bind_game top;
+  Button.configure newg [Command game_init];
+  Button.configure exitg [Command (fun () -> exit 0)];
+  game_init ()
+;;
+
+let tetris () =
+ start_game ();
+ Printexc.print mainLoop ()
+;;
 
-let _ = Printexc.print mainLoop ()
+if !Sys.interactive then () else begin tetris (); exit 0 end;;
diff --git a/otherlibs/labltk/examples_labltk/Makefile b/otherlibs/labltk/examples_labltk/Makefile
index 3fa02632..ed5f4da7 100644
--- a/otherlibs/labltk/examples_labltk/Makefile
+++ b/otherlibs/labltk/examples_labltk/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support
diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt
index bd10e09d..f3a127b6 100644
--- a/otherlibs/labltk/examples_labltk/Makefile.nt
+++ b/otherlibs/labltk/examples_labltk/Makefile.nt
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 # We are using the non-installed library !
diff --git a/otherlibs/labltk/examples_labltk/README b/otherlibs/labltk/examples_labltk/README
index 88eaccda..ec0f20de 100644
--- a/otherlibs/labltk/examples_labltk/README
+++ b/otherlibs/labltk/examples_labltk/README
@@ -1,4 +1,4 @@
-$Id: README 4745 2002-04-26 12:16:26Z furuse $
+$Id$
 
 Some examples for LablTk.
 They are written in classic mode, except testris.ml which uses label
diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml
index ea973f29..17a410c8 100644
--- a/otherlibs/labltk/examples_labltk/calc.ml
+++ b/otherlibs/labltk/examples_labltk/calc.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: calc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* A simple calculator demonstrating OO programming with O'Labl
    and LablTk.
diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml
index 7f2164b2..6903acb2 100644
--- a/otherlibs/labltk/examples_labltk/clock.ml
+++ b/otherlibs/labltk/examples_labltk/clock.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: clock.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Clock/V, a simple clock.
    Reverts every time you push the right button.
diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml
index dcdd2cac..9524c1c7 100644
--- a/otherlibs/labltk/examples_labltk/demo.ml
+++ b/otherlibs/labltk/examples_labltk/demo.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: demo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Some CamlTk4 Demonstration by JPF *)
 
diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml
index 138f74be..74f59f6c 100644
--- a/otherlibs/labltk/examples_labltk/eyes.ml
+++ b/otherlibs/labltk/examples_labltk/eyes.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: eyes.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 
@@ -24,7 +24,7 @@ let _ =
   pack [fw];
   let c = Canvas.create ~width: 200 ~height: 200 fw in
   let create_eye cx cy wx wy ewx ewy bnd =
-    let o2 = Canvas.create_oval
+    let _o2 = Canvas.create_oval
         ~x1:(cx - wx) ~y1:(cy - wy)
         ~x2:(cx + wx) ~y2:(cy + wy)
         ~outline: `Black ~width: 7
diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml
index 2718c01d..838b50ff 100644
--- a/otherlibs/labltk/examples_labltk/hello.ml
+++ b/otherlibs/labltk/examples_labltk/hello.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hello.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* LablTk4 Demonstration by JPF *)
 
diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl
index 84ceccd6..6791d2e2 100755
--- a/otherlibs/labltk/examples_labltk/hello.tcl
+++ b/otherlibs/labltk/examples_labltk/hello.tcl
@@ -1,5 +1,21 @@
 #!/usr/bin/wish
 
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 button .hello -text "Hello, TclTk!"
 
 pack .hello
diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml
index 93b0849f..616f38cb 100644
--- a/otherlibs/labltk/examples_labltk/taquin.ml
+++ b/otherlibs/labltk/examples_labltk/taquin.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: taquin.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk;;
 
diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml
index 98752e60..28544e08 100644
--- a/otherlibs/labltk/examples_labltk/tetris.ml
+++ b/otherlibs/labltk/examples_labltk/tetris.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tetris.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* A Tetris game for LablTk *)
 (* written by Jun P. Furuse *)
@@ -268,7 +268,6 @@ let init fw =
   let scorev = Textvariable.create ()
   and linev = Textvariable.create ()
   and levv = Textvariable.create ()
-  and namev = Textvariable.create ()
   in
   let f = Frame.create fw ~borderwidth: 2 in
   let c = Canvas.create f ~width: (block_size * 10)
diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/frx/Makefile.nt
+++ b/otherlibs/labltk/frx/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml
index 73329994..0b7c339a 100644
--- a/otherlibs/labltk/frx/frx_entry.ml
+++ b/otherlibs/labltk/frx/frx_entry.ml
@@ -15,7 +15,7 @@
 (***********************************************************************)
 open Camltk
 
-let version = "$Id: frx_entry.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Tk 4.0 has emacs bindings for entry widgets
diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml
index f416b398..dfba7a0f 100644
--- a/otherlibs/labltk/frx/frx_fileinput.ml
+++ b/otherlibs/labltk/frx/frx_fileinput.ml
@@ -15,7 +15,7 @@
 (***********************************************************************)
 open Camltk
 
-let version = "$Id: frx_fileinput.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Simple spooling for fileinput callbacks
diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml
index d35553af..4acb5997 100644
--- a/otherlibs/labltk/frx/frx_font.ml
+++ b/otherlibs/labltk/frx/frx_font.ml
@@ -16,7 +16,7 @@
 open Camltk
 open Widget
 
-let version = "$Id: frx_font.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat.
diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml
index a9e8bcac..82ea8a8c 100644
--- a/otherlibs/labltk/frx/frx_lbutton.ml
+++ b/otherlibs/labltk/frx/frx_lbutton.ml
@@ -18,7 +18,7 @@ open Camltk
 open Widget
 
 
-let version = "$Id: frx_lbutton.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Simulate a button with a bitmap AND a label
diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml
index 30353d90..6d04262b 100644
--- a/otherlibs/labltk/frx/frx_listbox.ml
+++ b/otherlibs/labltk/frx/frx_listbox.ml
@@ -15,7 +15,7 @@
 (***********************************************************************)
 open Camltk
 
-let version = "$Id: frx_listbox.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Link a scrollbar and a listbox
diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml
index 0f5d5937..41590c14 100644
--- a/otherlibs/labltk/frx/frx_req.ml
+++ b/otherlibs/labltk/frx/frx_req.ml
@@ -20,7 +20,7 @@ open Camltk
  * jargon).
 *)
 
-let version = "$Id: frx_req.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * Simple requester
diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml
index 1a2b287e..a9ca17a3 100644
--- a/otherlibs/labltk/frx/frx_text.ml
+++ b/otherlibs/labltk/frx/frx_text.ml
@@ -15,7 +15,7 @@
 (***********************************************************************)
 open Camltk
 
-let version = "$Id: frx_text.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 
 (*
  * convert an integer to an absolute index
diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml
index 760829cc..90451343 100644
--- a/otherlibs/labltk/frx/frx_widget.ml
+++ b/otherlibs/labltk/frx/frx_widget.ml
@@ -16,7 +16,7 @@
 open Camltk
 open Widget
 
-let version = "$Id: frx_widget.ml 11156 2011-07-27 14:17:02Z doligez $"
+let version = "$Id$"
 (* Make a window (toplevel widget) resizeable *)
 let resizeable t =
   update_idletasks(); (* wait until layout is computed *)
diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/jpf/Makefile.nt
+++ b/otherlibs/labltk/jpf/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
index cea783c6..e880f277 100644
--- a/otherlibs/labltk/jpf/balloon.ml
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: balloon.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open StdLabels
 
diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli
index dfba3e5a..f3e65269 100644
--- a/otherlibs/labltk/jpf/balloon.mli
+++ b/otherlibs/labltk/jpf/balloon.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: balloon.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* easy balloon help facility *)
 open Widget
diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml
index 83d04b71..236f6174 100644
--- a/otherlibs/labltk/jpf/balloontest.ml
+++ b/otherlibs/labltk/jpf/balloontest.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: balloontest.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Tk
 open Widget
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
index 7efad720..23aaeb6d 100644
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ b/otherlibs/labltk/jpf/fileselect.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fileselect.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* file selection box *)
 
diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli
index 7ce515d3..42f7d34f 100644
--- a/otherlibs/labltk/jpf/fileselect.mli
+++ b/otherlibs/labltk/jpf/fileselect.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fileselect.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* This file selecter works only under the OS with the full unix support.
    For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt
index 046b8782..4feb527f 100644
--- a/otherlibs/labltk/labltk/Makefile.gen.nt
+++ b/otherlibs/labltk/labltk/Makefile.gen.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile.gen
diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/labltk/Makefile.nt
+++ b/otherlibs/labltk/labltk/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules
index bb8d3e5b..6298817b 100644
--- a/otherlibs/labltk/labltk/modules
+++ b/otherlibs/labltk/labltk/modules
@@ -1,4 +1,4 @@
-WIDGETOBJS=bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo 
+WIDGETOBJS= bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo
 bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml
 
 bell.cmo : bell.ml
diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/lib/Makefile.nt
+++ b/otherlibs/labltk/lib/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt
index 2b0b5ab5..74203f03 100644
--- a/otherlibs/labltk/support/Makefile.nt
+++ b/otherlibs/labltk/support/Makefile.nt
@@ -1 +1,17 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile
diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h
index dbd7101d..9efbbea3 100644
--- a/otherlibs/labltk/support/camltk.h
+++ b/otherlibs/labltk/support/camltk.h
@@ -14,7 +14,7 @@
 /*                                                                       */
 /*************************************************************************/
 
-/* $Id: camltk.h 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT)
 #define CAMLTKextern CAMLexport
@@ -27,10 +27,13 @@
 #define CONST84
 #endif
 
+/*Tcl_GetResult(), Tcl_GetStringResult(), Tcl_SetResult(), */
+  /*Tcl_SetStringResult(), Tcl_GetErrorLine() */
+
 /* if Tcl_GetStringResult is not defined, we use interp->result */
-#ifndef Tcl_GetStringResult
-#  define Tcl_GetStringResult(interp) (interp->result)
-#endif
+/*#ifndef Tcl_GetStringResult*/
+/*#  define Tcl_GetStringResult(interp) (interp->result)*/
+/*#endif*/
 
 /* cltkMisc.c */
 /* copy an OCaml string to the C heap. Must be deallocated with stat_free */
diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c
index b53efbb5..9a3d38a5 100644
--- a/otherlibs/labltk/support/cltkCaml.c
+++ b/otherlibs/labltk/support/cltkCaml.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkCaml.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c
index ce435c12..58374d8a 100644
--- a/otherlibs/labltk/support/cltkDMain.c
+++ b/otherlibs/labltk/support/cltkDMain.c
@@ -14,7 +14,7 @@
 /*                                                                       */
 /*************************************************************************/
 
-/* $Id: cltkDMain.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -162,7 +162,7 @@ int CamlRunCmd(dummy, interp, argc, argv)
                         + trail.symbol_size + trail.debug_size), 2);
 
     code_size = trail.code_size;
-    start_code = (code_t) stat_alloc(code_size);
+    start_code = (code_t) caml_stat_alloc(code_size);
     if (read(fd, (char *) start_code, code_size) != code_size)
       fatal_error("Fatal error: truncated bytecode file.\n");
 
@@ -215,7 +215,7 @@ int Caml_Init(interp)
   {
     char *home = getenv("HOME");
     if (home != NULL) {
-      char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
+      char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2);
       f[0]='\0';
       strcat(f, home);
       strcat(f, "/");
diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
index e751fff6..c7a43481 100644
--- a/otherlibs/labltk/support/cltkEval.c
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkEval.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -139,14 +139,14 @@ int fill_args (char **argv, int where, value v)
       char *merged;
       int i;
       int size = argv_size(Field(v,0));
-      tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
+      tmpargv = (char **)caml_stat_alloc((size + 1) * sizeof(char *));
       fill_args(tmpargv,0,Field(v,0));
       tmpargv[size] = NULL;
       merged = Tcl_Merge(size,(const char *const*)tmpargv);
       for(i = 0; i
 #include 
diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c
index be7ee8f6..c01f3954 100644
--- a/otherlibs/labltk/support/cltkFile.c
+++ b/otherlibs/labltk/support/cltkFile.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkFile.c 12716 2012-07-16 20:01:36Z doligez $ */
+/* $Id$ */
 
 #ifdef _WIN32
 #include 
diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c
index ca97c378..871a47ac 100644
--- a/otherlibs/labltk/support/cltkMain.c
+++ b/otherlibs/labltk/support/cltkMain.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkMain.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -113,7 +113,7 @@ CAMLprim value camltk_opentk(value argv)
         char **tkargv;
         char argcstr[256]; /* string of argc */
 
-        tkargv = (char**)stat_alloc(sizeof( char* ) * argc );
+        tkargv = (char**)caml_stat_alloc(sizeof( char* ) * argc );
         tmp = Field(argv, 1); /* starts from argv[1] */
         i = 0;
 
@@ -157,7 +157,7 @@ CAMLprim value camltk_opentk(value argv)
   {
     char *home = getenv("HOME");
     if (home != NULL) {
-      char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
+      char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2);
       f[0]='\0';
       strcat(f, home);
       strcat(f, "/");
diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c
index c9dd59ed..52c5d484 100644
--- a/otherlibs/labltk/support/cltkMisc.c
+++ b/otherlibs/labltk/support/cltkMisc.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkMisc.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -55,7 +55,7 @@ CAMLprim value camltk_splitlist (value v)
 char *string_to_c(value s)
 {
   int l = string_length(s);
-  char *res = stat_alloc(l + 1);
+  char *res = caml_stat_alloc(l + 1);
   memmove (res, String_val (s), l);
   res[l] = '\0';
   return res;
diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c
index dd34e7dd..afebef8e 100644
--- a/otherlibs/labltk/support/cltkTimer.c
+++ b/otherlibs/labltk/support/cltkTimer.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkTimer.c 12126 2012-02-05 09:20:46Z bmeurer $ */
+/* $Id$ */
 
 #include 
 #include 
diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c
index d12d6b46..61dbfb2f 100644
--- a/otherlibs/labltk/support/cltkUtf.c
+++ b/otherlibs/labltk/support/cltkUtf.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkUtf.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -43,7 +43,7 @@ char *external_to_utf( char *str ){
 
   Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr);
   length = Tcl_DStringLength(&dstr);
-  res = stat_alloc(length + 1);
+  res = caml_stat_alloc(length + 1);
   memmove( res, Tcl_DStringValue(&dstr), length+1);
   Tcl_DStringFree(&dstr);
 
@@ -57,7 +57,7 @@ char *utf_to_external( char *str ){
 
   Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr);
   length = Tcl_DStringLength(&dstr);
-  res = stat_alloc(length + 1);
+  res = caml_stat_alloc(length + 1);
   memmove( res, Tcl_DStringValue(&dstr), length+1);
   Tcl_DStringFree(&dstr);
 
diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c
index 5196edb7..e647d9d6 100644
--- a/otherlibs/labltk/support/cltkVar.c
+++ b/otherlibs/labltk/support/cltkVar.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkVar.c 12800 2012-07-30 18:59:07Z doligez $ */
+/* $Id$ */
 
 /* Alternative to tkwait variable */
 #include 
diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c
index bbdecb55..e13091f2 100644
--- a/otherlibs/labltk/support/cltkWait.c
+++ b/otherlibs/labltk/support/cltkWait.c
@@ -14,7 +14,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkWait.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 #include 
 #include 
@@ -62,7 +62,7 @@ static void WaitVisibilityProc(clientData, eventPtr)
 CAMLprim value camltk_wait_vis(value win, value cbid)
 {
   struct WinCBData *vis =
-    (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
+    (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData));
   vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
   if (vis -> win == NULL) {
     stat_free((char *)vis);
@@ -89,7 +89,7 @@ static void WaitWindowProc(ClientData clientData, XEvent *eventPtr)
 CAMLprim value camltk_wait_des(value win, value cbid)
 {
   struct WinCBData *vis =
-    (struct WinCBData *)stat_alloc(sizeof(struct WinCBData));
+    (struct WinCBData *)caml_stat_alloc(sizeof(struct WinCBData));
   vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
   if (vis -> win == NULL) {
     stat_free((char *)vis);
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index ced725af..7285a475 100644
--- a/otherlibs/labltk/support/fileevent.ml
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -14,10 +14,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fileevent.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Unix
-open Support
 open Protocol
 
 external add_file_input : file_descr -> cbid -> unit
diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli
index 2c4e5408..f5468ca5 100644
--- a/otherlibs/labltk/support/fileevent.mli
+++ b/otherlibs/labltk/support/fileevent.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fileevent.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Unix
 
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
index 41c7ac73..a61905dc 100644
--- a/otherlibs/labltk/support/protocol.ml
+++ b/otherlibs/labltk/support/protocol.ml
@@ -14,9 +14,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: protocol.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
-open Support
 open Widget
 
 type callback_buffer = string list
diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli
index 60d979af..1ce6718a 100644
--- a/otherlibs/labltk/support/protocol.mli
+++ b/otherlibs/labltk/support/protocol.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: protocol.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Widget
 
diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml
index 1a171e74..d4344ad9 100644
--- a/otherlibs/labltk/support/rawwidget.ml
+++ b/otherlibs/labltk/support/rawwidget.ml
@@ -14,9 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: rawwidget.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-open Support
+(* $Id$ *)
 
 (*
  * Widgets
diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli
index b61082d0..e9f82ef2 100644
--- a/otherlibs/labltk/support/rawwidget.mli
+++ b/otherlibs/labltk/support/rawwidget.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: rawwidget.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Support for widget manipulations *)
 
diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml
index cb9064ca..44349c05 100644
--- a/otherlibs/labltk/support/slave.ml
+++ b/otherlibs/labltk/support/slave.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: slave.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* The code run on initialisation, in addition to normal Tk code
  * NOTE: camltk has not fully been initialised yet
diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
index ada3ce67..7d019967 100644
--- a/otherlibs/labltk/support/support.ml
+++ b/otherlibs/labltk/support/support.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: support.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Parsing results of Tcl *)
 (* List.split a string according to char_sep predicate *)
diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
index 8cc21144..fe30208a 100644
--- a/otherlibs/labltk/support/support.mli
+++ b/otherlibs/labltk/support/support.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: support.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val split_str : pred:(char -> bool) -> string -> string list
 val may : ('a -> 'b) -> 'a option -> 'b option
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
index a1dbb279..bcd3a045 100644
--- a/otherlibs/labltk/support/textvariable.ml
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -14,9 +14,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: textvariable.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
-open Support
 open Protocol
 
 external internal_tracevar : string -> cbid -> unit
diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
index 9f1f98e6..f18f6cc8 100644
--- a/otherlibs/labltk/support/textvariable.mli
+++ b/otherlibs/labltk/support/textvariable.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: textvariable.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Support for Tk -textvariable option *)
 open Widget
diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
index 97db97db..fd232bc1 100644
--- a/otherlibs/labltk/support/timer.ml
+++ b/otherlibs/labltk/support/timer.ml
@@ -14,10 +14,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: timer.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Timers *)
-open Support
 open Protocol
 
 type tkTimer = int
diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli
index 23d4ede9..4b31668c 100644
--- a/otherlibs/labltk/support/timer.mli
+++ b/otherlibs/labltk/support/timer.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: timer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 type t
 
diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml
index bfe42573..4ae36685 100644
--- a/otherlibs/labltk/support/tkthread.ml
+++ b/otherlibs/labltk/support/tkthread.ml
@@ -12,7 +12,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tkthread.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 let jobs : (unit -> unit) Queue.t = Queue.create ()
 let m = Mutex.create ()
diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli
index 6c2143a4..2bc104da 100644
--- a/otherlibs/labltk/support/tkthread.mli
+++ b/otherlibs/labltk/support/tkthread.mli
@@ -12,7 +12,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tkthread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Helper functions for using LablTk with threads.
    To use, add tkthread.cmo or tkthread.cmx to your command line *)
diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml
index af2cc3c3..34f6908d 100644
--- a/otherlibs/labltk/support/tkwait.ml
+++ b/otherlibs/labltk/support/tkwait.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tkwait.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 external internal_tracevis : string -> Protocol.cbid -> unit
         = "camltk_wait_vis"
diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
index a82ec284..083e4b96 100644
--- a/otherlibs/labltk/support/widget.ml
+++ b/otherlibs/labltk/support/widget.ml
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: widget.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Hack to permit having the different data type with the same name
    [widget] for CamlTk and LablTk. *)
diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli
index 715d2e26..7761f2f2 100644
--- a/otherlibs/labltk/support/widget.mli
+++ b/otherlibs/labltk/support/widget.mli
@@ -14,7 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: widget.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Support for widget manipulations *)
 
diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
index 1ae0c7cc..e5bcb97c 100644
--- a/otherlibs/num/Makefile
+++ b/otherlibs/num/Makefile
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11886 2011-12-18 09:52:52Z xleroy $
+# $Id$
 
 # Makefile for the "num" (exact rational arithmetic) library
 
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 6d961d04..4ac69c7c 100644
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -11,7 +11,7 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11927 2011-12-21 16:31:01Z xleroy $
+# $Id$
 
 # Makefile for the "num" (exact rational arithmetic) library
 
diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml
index 3f63a01d..048d4f8d 100644
--- a/otherlibs/num/arith_flags.ml
+++ b/otherlibs/num/arith_flags.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arith_flags.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 let error_when_null_denominator_flag = ref true;;
 
diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli
index 58c9ff54..65394243 100644
--- a/otherlibs/num/arith_flags.mli
+++ b/otherlibs/num/arith_flags.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arith_flags.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 val error_when_null_denominator_flag : bool ref
 val normalize_ratio_flag : bool ref
diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml
index 8b393847..0f9deb36 100644
--- a/otherlibs/num/arith_status.ml
+++ b/otherlibs/num/arith_status.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arith_status.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Arith_flags;;
 
diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
index 25f8a5e7..170e8cd4 100644
--- a/otherlibs/num/arith_status.mli
+++ b/otherlibs/num/arith_status.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arith_status.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (** Flags that control rational arithmetic. *)
 
diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
index 29f45449..95c6f6a8 100644
--- a/otherlibs/num/big_int.ml
+++ b/otherlibs/num/big_int.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: big_int.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Int_misc
 open Nat
@@ -451,7 +451,6 @@ let power_base_nat base nat off len =
     let res = make_nat n
     and res2 = make_nat (succ n)
     and l = num_bits_int n - 2 in
-    let p = ref (1 lsl l) in
       blit_nat res 0 power_base pmax 1;
       for i = l downto 0 do
         let len = num_digits_nat res 0 n in
@@ -459,14 +458,13 @@ let power_base_nat base nat off len =
         let succ_len2 = succ len2 in
           ignore (square_nat res2 0 len2 res 0 len);
           begin
-           if n land !p > 0
+           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;
-          p := !p lsr 1
+          set_to_zero_nat res2 0 len2
       done;
     if rem > 0
      then (ignore (mult_digit_nat res2 0 (succ n)
@@ -496,21 +494,19 @@ let power_big_int_positive_int bi n =
          let res = make_nat res_len
          and res2 = make_nat res_len
          and l = num_bits_int n - 2 in
-         let p = ref (1 lsl l) 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 !p > 0 then begin
+           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;
-           p := !p lsr 1
+           end
          done;
          {sign = if bi.sign >=  0 then bi.sign
                  else if n land 1 = 0 then 1 else -1;
@@ -743,7 +739,13 @@ let extract_big_int bi ofs n =
     if bi.sign < 0 then begin
       (* Two's complement *)
       complement_nat res 0 size_res;
-      ignore (incr_nat res 0 size_res 1)
+      (* 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
diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
index 1482b922..fc75153e 100644
--- a/otherlibs/num/big_int.mli
+++ b/otherlibs/num/big_int.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: big_int.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (** Operations on arbitrary-precision integers.
 
@@ -155,13 +155,13 @@ val float_of_big_int : big_int -> float
 (** {6 Bit-oriented operations} *)
 
 val and_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical ``and''.
+        (** Bitwise logical 'and'.
             The arguments must be positive or zero. *)
 val or_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical ``or''.
+        (** Bitwise logical 'or'.
             The arguments must be positive or zero. *)
 val xor_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical ``exclusive or''.
+        (** 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.
diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
index b0428e61..5bbedb0b 100644
--- a/otherlibs/num/bng.c
+++ b/otherlibs/num/bng.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 #include "bng.h"
 #include "config.h"
diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
index 387090ee..19f2e2b9 100644
--- a/otherlibs/num/bng.h
+++ b/otherlibs/num/bng.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng.h 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 #include 
 #include "config.h"
diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
index 25fc0100..ecf9f253 100644
--- a/otherlibs/num/bng_amd64.c
+++ b/otherlibs/num/bng_amd64.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng_amd64.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /* Code specific to the AMD x86_64 architecture. */
 
diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
index f9ce2210..e429197c 100644
--- a/otherlibs/num/bng_digit.c
+++ b/otherlibs/num/bng_digit.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng_digit.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /**** Generic operations on digits ****/
 
diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
index aac3b1da..b4981cd4 100644
--- a/otherlibs/num/bng_ia32.c
+++ b/otherlibs/num/bng_ia32.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng_ia32.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /* Code specific to the Intel IA32 (x86) architecture. */
 
diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
index d16b3f2d..6bbf108e 100644
--- a/otherlibs/num/bng_ppc.c
+++ b/otherlibs/num/bng_ppc.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng_ppc.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /* Code specific to the PowerPC architecture. */
 
diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
index 95e45bb7..4e46a316 100644
--- a/otherlibs/num/bng_sparc.c
+++ b/otherlibs/num/bng_sparc.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bng_sparc.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /* Code specific to the SPARC (V8 and above) architecture. */
 
diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml
index b2950df1..99713b91 100644
--- a/otherlibs/num/int_misc.ml
+++ b/otherlibs/num/int_misc.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int_misc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Some extra operations on integers *)
 
diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli
index f2413332..7f465c5a 100644
--- a/otherlibs/num/int_misc.mli
+++ b/otherlibs/num/int_misc.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int_misc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Some extra operations on integers *)
 
diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h
index 912ec1c6..62c7ac98 100644
--- a/otherlibs/num/nat.h
+++ b/otherlibs/num/nat.h
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: nat.h 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id$ */
 
 /* Nats are represented as unstructured blocks with tag Custom_tag. */
 
diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
index 99e3f7de..d51a4810 100644
--- a/otherlibs/num/nat.ml
+++ b/otherlibs/num/nat.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nat.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Int_misc
 
@@ -355,8 +355,10 @@ let int_to_string int s pos_ref base times =
 (* XL: suppression de adjust_string *)
 
 let power_base_int base i =
-  if i = 0 then
+  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
@@ -370,22 +372,20 @@ let power_base_int base i =
                let res = make_nat newn
                and res2 = make_nat newn
                and l = num_bits_int n - 2 in
-               let p = ref (1 lsl l) 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 !p > 0 then begin
+                     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;
-                     p := !p lsr 1
+                     set_to_zero_nat res2 0 len2
                  done;
                if rem > 0 then begin
                  ignore
diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
index cb5c7b0a..39f1c590 100644
--- a/otherlibs/num/nat.mli
+++ b/otherlibs/num/nat.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nat.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 (* Module [Nat]: operations on natural numbers *)
 
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index fa0cce02..9a62759f 100644
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -11,7 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: nat_stubs.c 12800 2012-07-30 18:59:07Z doligez $ */
+/* $Id$ */
 
 #include "alloc.h"
 #include "config.h"
diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
index eaa74a80..4ede5ee4 100644
--- a/otherlibs/num/num.ml
+++ b/otherlibs/num/num.ml
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: num.ml 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id$ *)
 
 open Int_misc
 open Nat
diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
index 891109b5..17733384 100644
--- a/otherlibs/num/num.mli
+++ b/otherlibs/num/num.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: num.mli 12031 2012-01-17 20:32:33Z lefessan $ *)
+(* $Id$ *)
 
 (** Operation on arbitrary-precision numbers.
 
diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
index 640b7bf2..408aea9b 100644
--- a/otherlibs/num/ratio.mli
+++ b/otherlibs/num/ratio.mli
@@ -11,7 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ratio.mli 12301 2012-03-31 22:10:34Z doligez $ *)
+(* $Id$ *)
 
 (** Operation on rational numbers.
 
diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index 196d8692..509be62a 100644
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the str library
 
 
diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 5c809808..3b3f51c9 100644
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the str library
 
 LIBNAME=str
diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index 5fb06070..b9b8c153 100644
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: str.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** String utilities *)
 
 let string_before s n = String.sub s 0 n
@@ -212,7 +210,8 @@ let fold_case_table =
   for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done;
   t
 
-module StringMap = Map.Make(struct type t = string let compare = compare end)
+module StringMap =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
 
 (* Compilation of a regular expression *)
 
diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
index 46c86135..1eb92378 100644
--- a/otherlibs/str/str.mli
+++ b/otherlibs/str/str.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: str.mli 12922 2012-09-11 14:40:43Z doligez $ *)
-
 (** Regular expressions and high-level string processing *)
 
 
@@ -49,6 +47,21 @@ val regexp : string -> regexp
    - [\b    ] Matches word boundaries.
    - [\     ] Quotes special characters.  The special characters
               are [$^\.*+?[]].
+
+   Note: the argument to [regexp] is usually a string literal. In this
+   case, any backslash character in the regular expression must be
+   doubled to make it past the OCaml string parser. For example, the
+   following expression:
+   {[ let r = Str.regexp "hello \\([A-Za-z]+\\)" in
+      Str.replace_first r "\\1" "hello world" ]}
+   returns the string ["world"].
+
+   In particular, if you want a regular expression that matches a single
+   backslash character, you need to quote it in the argument to [regexp]
+   (according to the last item of the list above) by adding a second
+   backslash. Then you need to quote both backslashes (according to the
+   syntax of string constants in OCaml) by doubling them again, so you
+   need to write four backslash characters: [Str.regexp "\\\\"].
 *)
 
 val regexp_case_fold : string -> regexp
diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
index 97c67057..9de349a9 100644
--- a/otherlibs/str/strstubs.c
+++ b/otherlibs/str/strstubs.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: strstubs.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -300,7 +298,7 @@ static int re_match(value re,
     /* Push an item on the backtrack stack and continue with next instr */
     if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
       struct backtrack_stack * newstack =
-        stat_alloc(sizeof(struct backtrack_stack));
+        caml_stat_alloc(sizeof(struct backtrack_stack));
       newstack->previous = stack;
       stack = newstack;
       sp = stack->point;
diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index 502498f1..d6b8686b 100644
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -11,14 +11,12 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12585 2012-06-08 11:35:37Z xleroy $
-
 include ../../config/Makefile
 
 CAMLC=../../ocamlcomp.sh -I ../unix
 CAMLOPT=../../ocamlcompopt.sh -I ../unix
 MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A -g
+COMPFLAGS=-w +33..39 -warn-error A -g
 
 BYTECODE_C_OBJS=st_stubs_b.o
 NATIVECODE_C_OBJS=st_stubs_n.o
@@ -43,7 +41,9 @@ libthreadsnat.a: $(NATIVECODE_C_OBJS)
 	$(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS)
 
 st_stubs_n.o: st_stubs.c st_posix.h
-	$(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c st_stubs.c
+	$(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) \
+	            $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) \
+	            -DSYS_$(SYSTEM) -c st_stubs.c
 	mv st_stubs.o st_stubs_n.o
 
 threads.cma: $(THREAD_OBJS)
diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
index dc118b71..225146cc 100644
--- a/otherlibs/systhreads/Makefile.nt
+++ b/otherlibs/systhreads/Makefile.nt
@@ -11,14 +11,12 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 include ../../config/Makefile
 
 # Compilation options
 CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix
 CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix
-COMPFLAGS=-warn-error A -g
+COMPFLAGS=-w +33 -warn-error A -g
 MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
 CFLAGS=-I../../byterun $(EXTRACFLAGS)
 
@@ -34,7 +32,8 @@ all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
 allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES)
 
 $(LIBNAME).cma: $(CAMLOBJS)
-	$(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS)
+	$(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" \
+	         -linkall $(CAMLOBJS) $(LINKOPTS)
 
 lib$(LIBNAME).$(A): $(COBJS)
 	$(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS)
@@ -46,7 +45,9 @@ st_stubs_b.$(O): st_stubs.c st_win32.h
 
 
 $(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx)
-	$(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
+	$(MKLIB) -o $(LIBNAME)nat \
+	         -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall \
+	         $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
 	mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa
 	mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A)
 
@@ -57,7 +58,8 @@ lib$(LIBNAME)nat.$(A): $(COBJS_NAT)
 	$(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS)
 
 st_stubs_n.$(O): st_stubs.c st_win32.h
-	$(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c st_stubs.c
+	$(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun \
+	            $(NATIVECCCOMPOPTS) -c st_stubs.c
 	mv st_stubs.$(O) st_stubs_n.$(O)
 
 $(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml
index fed1b3fa..4d12378d 100644
--- a/otherlibs/systhreads/condition.ml
+++ b/otherlibs/systhreads/condition.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: condition.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type t
 external create: unit -> t = "caml_condition_new"
 external wait: t -> Mutex.t -> unit = "caml_condition_wait"
diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli
index ec8b8b24..9e005dc6 100644
--- a/otherlibs/systhreads/condition.mli
+++ b/otherlibs/systhreads/condition.mli
@@ -11,13 +11,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: condition.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Condition variables to synchronize between threads.
 
    Condition variables are used when one thread wants to wait until another
-   thread has finished doing something: the former thread ``waits'' on the
-   condition variable, the latter thread ``signals'' the condition when it
+   thread has finished doing something: the former thread 'waits' on the
+   condition variable, the latter thread 'signals' the condition when it
    is done. Condition variables should always be protected by a mutex.
    The typical use is (if [D] is a shared data structure, [m] its mutex,
    and [c] is a condition variable):
diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml
index 66adc439..1feac525 100644
--- a/otherlibs/systhreads/event.ml
+++ b/otherlibs/systhreads/event.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: event.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Events *)
 type 'a basic_event =
   { poll: unit -> bool;
diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli
index ca8138ec..8352ca1f 100644
--- a/otherlibs/systhreads/event.mli
+++ b/otherlibs/systhreads/event.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: event.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** First-class synchronous communication.
 
    This module implements synchronous inter-thread communications over
@@ -64,13 +62,13 @@ val guard : (unit -> 'a event) -> 'a event
    operation. *)
 
 val sync : 'a event -> 'a
-(** ``Synchronize'' on an event: offer all the communication
+(** 'Synchronize' on an event: offer all the communication
    possibilities specified in the event to the outside world,
    and block until one of the communications succeed. The result
    value of that communication is returned. *)
 
 val select : 'a event list -> 'a
-(** ``Synchronize'' on an alternative of events.
+(** 'Synchronize' on an alternative of events.
    [select evl] is shorthand for [sync(choose evl)]. *)
 
 val poll : 'a event -> 'a option
diff --git a/otherlibs/systhreads/mutex.ml b/otherlibs/systhreads/mutex.ml
index 78a0116e..5b8be9da 100644
--- a/otherlibs/systhreads/mutex.ml
+++ b/otherlibs/systhreads/mutex.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mutex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type t
 external create: unit -> t = "caml_mutex_new"
 external lock: t -> unit = "caml_mutex_lock"
diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli
index c18c79ba..265ae94e 100644
--- a/otherlibs/systhreads/mutex.mli
+++ b/otherlibs/systhreads/mutex.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mutex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Locks for mutual exclusion.
 
    Mutexes (mutual-exclusion locks) are used to implement critical sections
diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index 44b47511..e0bc65e4 100644
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id$ */
-
 /* POSIX thread implementation of the "st" interface */
 
 #include 
diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index 78d6d925..dd99c736 100644
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: st_stubs.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include "alloc.h"
 #include "backtrace.h"
 #include "callback.h"
@@ -306,7 +304,7 @@ static caml_thread_t caml_thread_new_info(void)
   th->exit_buf = NULL;
 #else
   /* Allocate the stacks */
-  th->stack_low = (value *) stat_alloc(Thread_stack_size);
+  th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
   th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
   th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
   th->sp = th->stack_high;
@@ -408,7 +406,7 @@ CAMLprim value caml_thread_initialize(value unit)   /* ML */
   st_tls_newkey(&last_channel_locked_key);
   /* Set up a thread info block for the current thread */
   curr_thread =
-    (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
+    (caml_thread_t) caml_stat_alloc(sizeof(struct caml_thread_struct));
   curr_thread->descr = caml_thread_new_descriptor(Val_unit);
   curr_thread->next = curr_thread;
   curr_thread->prev = curr_thread;
@@ -825,7 +823,7 @@ CAMLprim value caml_condition_signal(value wrapper)           /* ML */
 CAMLprim value caml_condition_broadcast(value wrapper)           /* ML */
 {
   st_check_error(st_condvar_broadcast(Condition_val(wrapper)),
-                 "Condition.signal");
+                 "Condition.broadcast");
   return Val_unit;
 }
 
diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h
index 206646df..cd04b319 100644
--- a/otherlibs/systhreads/st_win32.h
+++ b/otherlibs/systhreads/st_win32.h
@@ -11,13 +11,11 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id$ */
-
 /* Win32 implementation of the "st" interface */
 
 #define _WIN32_WINNT 0x0400
 #include 
-#include 
+#include 
 #include 
 #include 
 
@@ -29,7 +27,8 @@
 #else
 #include 
 #define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout)
-#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); fflush(stdout)
+#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); \
+                    fflush(stdout)
 #endif
 
 typedef DWORD st_retcode;
diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml
index ee01c955..c7988b56 100644
--- a/otherlibs/systhreads/thread.ml
+++ b/otherlibs/systhreads/thread.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (* User-level threads *)
 
 type t
@@ -85,5 +83,6 @@ let select = Unix.select
 
 let wait_pid p = Unix.waitpid [] p
 
-external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask"
+external sigmask : Unix.sigprocmask_command -> int list -> int list
+   = "caml_thread_sigmask"
 external wait_signal : int list -> int = "caml_wait_signal"
diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
index f60e6227..93e52be2 100644
--- a/otherlibs/systhreads/thread.mli
+++ b/otherlibs/systhreads/thread.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: thread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Lightweight threads for Posix [1003.1c] and Win32. *)
 
 type t
diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml
index 28654794..335afcb0 100644
--- a/otherlibs/systhreads/threadUnix.ml
+++ b/otherlibs/systhreads/threadUnix.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [ThreadUnix]: thread-compatible system calls *)
 
 open Unix
diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
index 8ad70099..63d27335 100644
--- a/otherlibs/systhreads/threadUnix.mli
+++ b/otherlibs/systhreads/threadUnix.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Thread-compatible system calls.
 
    @deprecated The functionality of this module has been merged back into
diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h
index ff140cd5..6a97b251 100644
--- a/otherlibs/systhreads/threads.h
+++ b/otherlibs/systhreads/threads.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id$ */
-
 #ifndef CAML_THREADS_H
 #define CAML_THREADS_H
 
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index bc03050b..c96a6715 100644
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -11,25 +11,22 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \
   ../../byterun/sys.h
 condition.cmi : mutex.cmi
 event.cmi :
-marshal.cmi :
 mutex.cmi :
-pervasives.cmi :
-thread.cmi : unix.cmi
-threadUnix.cmi : unix.cmi
-unix.cmi :
+thread.cmi : unix.cmo
+threadUnix.cmi : unix.cmo
 condition.cmo : thread.cmi mutex.cmi condition.cmi
 condition.cmx : thread.cmx mutex.cmx condition.cmi
 event.cmo : mutex.cmi condition.cmi event.cmi
 event.cmx : mutex.cmx condition.cmx event.cmi
-marshal.cmo : pervasives.cmi marshal.cmi
-marshal.cmx : pervasives.cmx marshal.cmi
+marshal.cmo : pervasives.cmo
+marshal.cmx : pervasives.cmx
 mutex.cmo : thread.cmi mutex.cmi
 mutex.cmx : thread.cmx mutex.cmi
-pervasives.cmo : unix.cmi pervasives.cmi
-pervasives.cmx : unix.cmx pervasives.cmi
-thread.cmo : unix.cmi thread.cmi
+pervasives.cmo : unix.cmo
+pervasives.cmx : unix.cmx
+thread.cmo : unix.cmo thread.cmi
 thread.cmx : unix.cmx thread.cmi
-threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi
+threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
 threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
-unix.cmo : unix.cmi
-unix.cmx : unix.cmi
+unix.cmo :
+unix.cmx :
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index 07d38631..311373bb 100644
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -11,15 +11,13 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12867 2012-08-21 04:39:34Z garrigue $
-
 include ../../config/Makefile
 
 CC=$(BYTECC)
 CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
 CAMLC=../../ocamlcomp.sh -I ../unix
 MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error A
+COMPFLAGS=-w +33..39 -warn-error A
 
 C_OBJS=scheduler.o
 
@@ -102,8 +100,10 @@ install:
 	mkdir -p $(LIBDIR)/vmthreads
 	cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a
 	cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
-	cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads
-	cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads
+	cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \
+	   threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads
+	cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
+	   $(LIBDIR)/vmthreads
 
 installopt:
 
diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml
index ac477984..7912cd60 100644
--- a/otherlibs/threads/condition.ml
+++ b/otherlibs/threads/condition.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: condition.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type t = { mutable waiting: Thread.t list }
 
 let create () = { waiting = [] }
diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli
index ec8b8b24..2d5bcde1 100644
--- a/otherlibs/threads/condition.mli
+++ b/otherlibs/threads/condition.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: condition.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Condition variables to synchronize between threads.
 
    Condition variables are used when one thread wants to wait until another
diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml
index 66adc439..1feac525 100644
--- a/otherlibs/threads/event.ml
+++ b/otherlibs/threads/event.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: event.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Events *)
 type 'a basic_event =
   { poll: unit -> bool;
diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli
index dc5a0a0b..e38235f1 100644
--- a/otherlibs/threads/event.mli
+++ b/otherlibs/threads/event.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: event.mli 12386 2012-04-20 15:33:00Z doligez $ *)
-
 (** First-class synchronous communication.
 
    This module implements synchronous inter-thread communications over
diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml
index 19b7e1b6..c71ca83d 100644
--- a/otherlibs/threads/marshal.ml
+++ b/otherlibs/threads/marshal.ml
@@ -11,11 +11,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type extern_flags =
     No_sharing
   | Closures
+  | Compat_32
 
 external to_string: 'a -> extern_flags list -> string
     = "caml_output_value_to_string"
diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml
index f96965e7..976527ce 100644
--- a/otherlibs/threads/mutex.ml
+++ b/otherlibs/threads/mutex.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mutex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type t = { mutable locked: bool; mutable waiting: Thread.t list }
 
 let create () = { locked = false; waiting = [] }
diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli
index c18c79ba..265ae94e 100644
--- a/otherlibs/threads/mutex.mli
+++ b/otherlibs/threads/mutex.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mutex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Locks for mutual exclusion.
 
    Mutexes (mutual-exclusion locks) are used to implement critical sections
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 2ddb980c..fdba7953 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Same as ../../stdlib/pervasives.ml, except that I/O functions have
    been redefined to not block the whole process, but only the calling
    thread. *)
@@ -28,6 +26,11 @@ let invalid_arg s = raise(Invalid_argument s)
 
 exception Exit
 
+(* Composition operators *)
+
+external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
 (* Comparisons *)
 
 external (=) : 'a -> 'a -> bool = "%equal"
@@ -94,7 +97,8 @@ external acos : float -> float = "caml_acos_float" "acos" "float"
 external asin : float -> float = "caml_asin_float" "asin" "float"
 external atan : float -> float = "caml_atan_float" "atan" "float"
 external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
-external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float"
+external hypot : float -> float -> float
+   = "caml_hypot_float" "caml_hypot" "float"
 external cos : float -> float = "caml_cos_float" "cos" "float"
 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 external log : float -> float = "caml_log_float" "log" "float"
@@ -108,7 +112,8 @@ external tanh : float -> float = "caml_tanh_float" "tanh" "float"
 external ceil : float -> float = "caml_ceil_float" "ceil" "float"
 external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
-external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float"
+external copysign : float -> float -> float
+   = "caml_copysign_float" "caml_copysign" "float"
 external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 external frexp : float -> float * int = "caml_frexp_float"
 external ldexp : float -> int -> float = "caml_ldexp_float"
diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index bd67cf70..45ef854d 100644
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: scheduler.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* The thread scheduler */
 
 #include 
@@ -227,7 +225,7 @@ value thread_new(value clos)          /* ML */
   End_roots();
   th->ident = next_ident;
   next_ident = Val_int(Int_val(next_ident) + 1);
-  th->stack_low = (value *) stat_alloc(Thread_stack_size);
+  th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
   th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
   th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
   th->sp = th->stack_high;
diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml
index 2b00b98e..6ef9997d 100644
--- a/otherlibs/threads/thread.ml
+++ b/otherlibs/threads/thread.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: thread.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* User-level threads *)
 
 type t
@@ -28,6 +26,11 @@ type resumption_status =
       Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
   | Resumed_wait of int * Unix.process_status
 
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+         Resumed_io; Resumed_select ([], [], []);
+         Resumed_wait (0, Unix.WEXITED 0)]
+
 (* It is mucho important that the primitives that reschedule are called
    through an ML function call, not directly. That's because when such a
    primitive returns, the bytecode interpreter is only semi-obedient:
@@ -39,7 +42,8 @@ type resumption_status =
    must take exactly one argument. *)
 
 external thread_initialize : unit -> unit = "thread_initialize"
-external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption"
+external thread_initialize_preemption : unit -> unit
+   = "thread_initialize_preemption"
 external thread_new : (unit -> unit) -> t = "thread_new"
 external thread_yield : unit -> unit = "thread_yield"
 external thread_request_reschedule : unit -> unit = "thread_request_reschedule"
diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index 3ee577d9..e026a214 100644
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: thread.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Lightweight threads. *)
 
 type t
diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
index 04dea9ea..fe5ef4fd 100644
--- a/otherlibs/threads/threadUnix.ml
+++ b/otherlibs/threads/threadUnix.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [ThreadUnix]: thread-compatible system calls *)
 
 let execv = Unix.execv
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index 554d504c..4ebe28f4 100644
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: threadUnix.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Thread-compatible system calls.
 
    @deprecated The functionality of this module has been merged back into
diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index e985aa46..80ea7aed 100644
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml 11304 2011-12-13 16:18:13Z frisch $ *)
-
 (* An alternate implementation of the Unix module from ../unix
    which is safe in conjunction with bytecode threads. *)
 
@@ -36,6 +34,11 @@ type resumption_status =
   | Resumed_select of file_descr list * file_descr list * file_descr list
   | Resumed_wait of int * process_status
 
+(* to avoid warning *)
+let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
+         Resumed_io; Resumed_select ([], [], []);
+         Resumed_wait (0, WEXITED 0)]
+
 external thread_initialize : unit -> unit = "thread_initialize"
 external thread_wait_read : file_descr -> unit = "thread_wait_read"
 external thread_wait_write : file_descr -> unit = "thread_wait_write"
@@ -193,6 +196,7 @@ type open_flag =
   | O_SYNC
   | O_RSYNC
   | O_SHARE_DELETE
+  | O_CLOEXEC
 
 type file_perm = int
 
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index ef8832f9..7cd527b1 100644
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -12,7 +12,9 @@ access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
 addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \
   ../../byterun/compatibility.h ../../byterun/config.h \
   ../../byterun/../config/m.h ../../byterun/../config/s.h \
-  ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/mlvalues.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
   unixsupport.h socketaddr.h ../../byterun/misc.h
 alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index 3f531d67..5f4d72b8 100644
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the Unix interface library
 
 LIBNAME=unix
diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c
index 9aa24185..183b8e86 100644
--- a/otherlibs/unix/accept.c
+++ b/otherlibs/unix/accept.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: accept.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
index d6c1c145..3a612a34 100644
--- a/otherlibs/unix/access.c
+++ b/otherlibs/unix/access.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: access.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
index f33c9f65..e17841f9 100644
--- a/otherlibs/unix/addrofstr.c
+++ b/otherlibs/unix/addrofstr.c
@@ -11,9 +11,8 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: addrofstr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
+#include 
 #include 
 #include "unixsupport.h"
 
@@ -24,6 +23,39 @@
 CAMLprim value unix_inet_addr_of_string(value s)
 {
 #if defined(HAS_IPV6)
+#ifdef _WIN32
+  CAMLparam1(s);
+  CAMLlocal1(vres);
+  struct addrinfo hints;
+  struct addrinfo * res;
+  int retcode;
+  memset(&hints, 0, sizeof(hints));
+  hints.ai_family = AF_UNSPEC;
+  hints.ai_flags = AI_NUMERICHOST;
+  retcode = getaddrinfo(String_val(s), NULL, &hints, &res);
+  if (retcode != 0) failwith("inet_addr_of_string");
+  switch (res->ai_addr->sa_family) {
+  case AF_INET:
+    {
+      vres =
+        alloc_inet_addr(&((struct sockaddr_in *) res->ai_addr)->sin_addr);
+      break;
+    }
+  case AF_INET6:
+    {
+      vres =
+        alloc_inet6_addr(&((struct sockaddr_in6 *) res->ai_addr)->sin6_addr);
+      break;
+    }
+  default:
+    {
+      freeaddrinfo(res);
+      failwith("inet_addr_of_string");
+    }
+  }
+  freeaddrinfo(res);
+  CAMLreturn (vres);
+#else
   struct in_addr address;
   struct in6_addr address6;
   if (inet_pton(AF_INET, String_val(s), &address) > 0)
@@ -32,6 +64,7 @@ CAMLprim value unix_inet_addr_of_string(value s)
     return alloc_inet6_addr(&address6);
   else
     failwith("inet_addr_of_string");
+#endif
 #elif defined(HAS_INET_ATON)
   struct in_addr address;
   if (inet_aton(String_val(s), &address) == 0)
diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c
index a1df8859..30472765 100644
--- a/otherlibs/unix/alarm.c
+++ b/otherlibs/unix/alarm.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: alarm.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c
index 3297a830..e3d0046c 100644
--- a/otherlibs/unix/bind.c
+++ b/otherlibs/unix/bind.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bind.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
index 6ec32340..e7ea6f50 100644
--- a/otherlibs/unix/chdir.c
+++ b/otherlibs/unix/chdir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: chdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
index 730b2fa9..ed2e88c8 100644
--- a/otherlibs/unix/chmod.c
+++ b/otherlibs/unix/chmod.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: chmod.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
index 493162e5..a26f7a86 100644
--- a/otherlibs/unix/chown.c
+++ b/otherlibs/unix/chown.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: chown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
index fee76678..02a46aed 100644
--- a/otherlibs/unix/chroot.c
+++ b/otherlibs/unix/chroot.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: chroot.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c
index ad821347..425502aa 100644
--- a/otherlibs/unix/close.c
+++ b/otherlibs/unix/close.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: close.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
index 6efd7ba8..ba9e7437 100644
--- a/otherlibs/unix/closedir.c
+++ b/otherlibs/unix/closedir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: closedir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include 
diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c
index 0388a217..ed8b12c3 100644
--- a/otherlibs/unix/connect.c
+++ b/otherlibs/unix/connect.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: connect.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c
index f84e4757..f27cace7 100644
--- a/otherlibs/unix/cst2constr.c
+++ b/otherlibs/unix/cst2constr.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cst2constr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "cst2constr.h"
diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h
index 3fec26d8..88985e52 100644
--- a/otherlibs/unix/cst2constr.h
+++ b/otherlibs/unix/cst2constr.h
@@ -11,6 +11,4 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cst2constr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
 extern value cst_to_constr(int n, int * tbl, int size, int deflt);
diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
index 11402403..d8541100 100644
--- a/otherlibs/unix/cstringv.c
+++ b/otherlibs/unix/cstringv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cstringv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
@@ -23,7 +21,7 @@ char ** cstringvect(value arg)
   mlsize_t size, i;
 
   size = Wosize_val(arg);
-  res = (char **) stat_alloc((size + 1) * sizeof(char *));
+  res = (char **) caml_stat_alloc((size + 1) * sizeof(char *));
   for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i));
   res[size] = NULL;
   return res;
diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c
index 77c66c77..36e3efac 100644
--- a/otherlibs/unix/dup.c
+++ b/otherlibs/unix/dup.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dup.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c
index d41ce480..c5018022 100644
--- a/otherlibs/unix/dup2.c
+++ b/otherlibs/unix/dup2.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dup2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
index d27809a2..4b189334 100644
--- a/otherlibs/unix/envir.c
+++ b/otherlibs/unix/envir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: envir.c 11176 2011-09-05 09:25:26Z xclerc $ */
-
 #include 
 #include 
 
diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
index 9b091962..5df3e1e7 100644
--- a/otherlibs/unix/errmsg.c
+++ b/otherlibs/unix/errmsg.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: errmsg.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
index c64395b2..ee59fa48 100644
--- a/otherlibs/unix/execv.c
+++ b/otherlibs/unix/execv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: execv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c
index b122c333..62b2d2c9 100644
--- a/otherlibs/unix/execve.c
+++ b/otherlibs/unix/execve.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: execve.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c
index f1cb5d7e..8e28fa06 100644
--- a/otherlibs/unix/execvp.c
+++ b/otherlibs/unix/execvp.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: execvp.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c
index 7bc11582..94f5fb5e 100644
--- a/otherlibs/unix/exit.c
+++ b/otherlibs/unix/exit.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: exit.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c
index b2e01f58..a6e8ee90 100644
--- a/otherlibs/unix/fchmod.c
+++ b/otherlibs/unix/fchmod.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fchmod.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c
index 28a0b9dc..574d3c42 100644
--- a/otherlibs/unix/fchown.c
+++ b/otherlibs/unix/fchown.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fchown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c
index d42e064c..886c12de 100644
--- a/otherlibs/unix/fcntl.c
+++ b/otherlibs/unix/fcntl.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fcntl.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index 2fc82bae..b21d80c6 100644
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fork.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
index 96a68490..f539a645 100644
--- a/otherlibs/unix/ftruncate.c
+++ b/otherlibs/unix/ftruncate.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: ftruncate.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
index 3b937f2e..cf3bb4a5 100644
--- a/otherlibs/unix/getaddrinfo.c
+++ b/otherlibs/unix/getaddrinfo.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getaddrinfo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -69,7 +67,7 @@ CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
   if (len == 0) {
     node = NULL;
   } else {
-    node = stat_alloc(len + 1);
+    node = caml_stat_alloc(len + 1);
     strcpy(node, String_val(vnode));
   }
   /* Extract "service" parameter */
@@ -77,7 +75,7 @@ CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
   if (len == 0) {
     serv = NULL;
   } else {
-    serv = stat_alloc(len + 1);
+    serv = caml_stat_alloc(len + 1);
     strcpy(serv, String_val(vserv));
   }
   /* Parse options, set hints */
diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
index db2f165b..8d1b8e50 100644
--- a/otherlibs/unix/getcwd.c
+++ b/otherlibs/unix/getcwd.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getcwd.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c
index 887eaa4b..b1977ec9 100644
--- a/otherlibs/unix/getegid.c
+++ b/otherlibs/unix/getegid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getegid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c
index 06b7df50..9bf89714 100644
--- a/otherlibs/unix/geteuid.c
+++ b/otherlibs/unix/geteuid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: geteuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c
index 51c38074..8cfe3ddb 100644
--- a/otherlibs/unix/getgid.c
+++ b/otherlibs/unix/getgid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getgid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c
index b2b87eb2..d1e610d8 100644
--- a/otherlibs/unix/getgr.c
+++ b/otherlibs/unix/getgr.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getgr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c
index 0b5d1da5..6d420b5e 100644
--- a/otherlibs/unix/getgroups.c
+++ b/otherlibs/unix/getgroups.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
index 79743b23..e155152f 100644
--- a/otherlibs/unix/gethost.c
+++ b/otherlibs/unix/gethost.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gethost.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -129,7 +127,7 @@ CAMLprim value unix_gethostbyname(value name)
   char * hostname;
 
 #if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
-  hostname = stat_alloc(string_length(name) + 1);
+  hostname = caml_stat_alloc(string_length(name) + 1);
   strcpy(hostname, String_val(name));
 #else
   hostname = String_val(name);
diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c
index 4ff3696f..77b183cb 100644
--- a/otherlibs/unix/gethostname.c
+++ b/otherlibs/unix/gethostname.c
@@ -11,14 +11,10 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gethostname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
-#if defined (_WIN32)
-#include 
-#else
+#ifndef _WIN32
 #include 
 #endif
 #include "unixsupport.h"
diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c
index a11e320a..27a508e0 100644
--- a/otherlibs/unix/getlogin.c
+++ b/otherlibs/unix/getlogin.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getlogin.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c
index a052cde7..d7dddb3f 100644
--- a/otherlibs/unix/getnameinfo.c
+++ b/otherlibs/unix/getnameinfo.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getnameinfo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
index fbc37ead..9692202c 100644
--- a/otherlibs/unix/getpeername.c
+++ b/otherlibs/unix/getpeername.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpeername.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c
index 41c737af..cf4c3f90 100644
--- a/otherlibs/unix/getpid.c
+++ b/otherlibs/unix/getpid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c
index 385d282e..616393b4 100644
--- a/otherlibs/unix/getppid.c
+++ b/otherlibs/unix/getppid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getppid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c
index 07173b37..291a71da 100644
--- a/otherlibs/unix/getproto.c
+++ b/otherlibs/unix/getproto.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getproto.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -23,8 +21,6 @@
 
 #ifndef _WIN32
 #include 
-#else
-#include 
 #endif
 
 static value alloc_proto_entry(struct protoent *entry)
diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c
index 963ddb1d..0061ca80 100644
--- a/otherlibs/unix/getpw.c
+++ b/otherlibs/unix/getpw.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -29,7 +27,7 @@ static value alloc_passwd_entry(struct passwd *entry)
   Begin_roots5 (name, passwd, gecos, dir, shell);
     name = copy_string(entry->pw_name);
     passwd = copy_string(entry->pw_passwd);
-#ifndef __BEOS__
+#if !defined(__BEOS__) && !defined(__ANDROID__)
     gecos = copy_string(entry->pw_gecos);
 #else
     gecos = copy_string("");
diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c
index eb99484a..de91cbe0 100644
--- a/otherlibs/unix/getserv.c
+++ b/otherlibs/unix/getserv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getserv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -27,8 +25,6 @@
 #include 
 #include 
 #include 
-#else
-#include 
 #endif
 
 static value alloc_service_entry(struct servent *entry)
diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c
index 84ec9aea..69e20ccc 100644
--- a/otherlibs/unix/getsockname.c
+++ b/otherlibs/unix/getsockname.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getsockname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c
index ddf75ff5..f6a8615e 100644
--- a/otherlibs/unix/gettimeofday.c
+++ b/otherlibs/unix/gettimeofday.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gettimeofday.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c
index 75d0f97c..f51722a5 100644
--- a/otherlibs/unix/getuid.c
+++ b/otherlibs/unix/getuid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c
index 7bf77b2c..c8f6ac11 100644
--- a/otherlibs/unix/gmtime.c
+++ b/otherlibs/unix/gmtime.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gmtime.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c
index 90332f69..e9541e5a 100644
--- a/otherlibs/unix/initgroups.c
+++ b/otherlibs/unix/initgroups.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: initgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c
index 250fb513..800afc46 100644
--- a/otherlibs/unix/isatty.c
+++ b/otherlibs/unix/isatty.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: isatty.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
index 279dff78..537c2d9e 100644
--- a/otherlibs/unix/itimer.c
+++ b/otherlibs/unix/itimer.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: itimer.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
index afbdcc3f..b3f7d887 100644
--- a/otherlibs/unix/kill.c
+++ b/otherlibs/unix/kill.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: kill.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c
index fdf537c3..b5051cd9 100644
--- a/otherlibs/unix/link.c
+++ b/otherlibs/unix/link.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: link.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c
index db3c16f2..26b0185b 100644
--- a/otherlibs/unix/listen.c
+++ b/otherlibs/unix/listen.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: listen.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
index 5efc5a76..813a4f7f 100644
--- a/otherlibs/unix/lockf.c
+++ b/otherlibs/unix/lockf.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: lockf.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
index c2013703..826d84f2 100644
--- a/otherlibs/unix/lseek.c
+++ b/otherlibs/unix/lseek.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: lseek.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
index 8ec4f1b1..0bb1f4f5 100644
--- a/otherlibs/unix/mkdir.c
+++ b/otherlibs/unix/mkdir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mkdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
index 9fa159e0..ec3bed4b 100644
--- a/otherlibs/unix/mkfifo.c
+++ b/otherlibs/unix/mkfifo.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mkfifo.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c
index 400543cf..019e2d1c 100644
--- a/otherlibs/unix/nice.c
+++ b/otherlibs/unix/nice.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: nice.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include 
diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
index 4a9ae092..ecee0138 100644
--- a/otherlibs/unix/open.c
+++ b/otherlibs/unix/open.c
@@ -11,14 +11,15 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c 11304 2011-12-13 16:18:13Z frisch $ */
-
 #include 
 #include 
 #include 
 #include 
 #include "unixsupport.h"
 #include 
+#ifdef HAS_UNISTD
+#include 
+#endif
 #include 
 
 #ifndef O_NONBLOCK
@@ -33,26 +34,49 @@
 #ifndef O_RSYNC
 #define O_RSYNC 0
 #endif
+#ifndef O_CLOEXEC
+#define NEED_CLOEXEC_EMULATION
+#define O_CLOEXEC 0
+#endif
 
-static int open_flag_table[] = {
+static int open_flag_table[14] = {
   O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
-  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0
+  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC,
+  0, /* O_SHARE_DELETE, Windows-only */
+  O_CLOEXEC
 };
 
+#ifdef NEED_CLOEXEC_EMULATION
+static int open_cloexec_table[14] = {
+  0, 0, 0, 0, 0, 0, 0, 0,
+  0, 0, 0, 0,
+  0,
+  1
+};
+#endif
+
 CAMLprim value unix_open(value path, value flags, value perm)
 {
   CAMLparam3(path, flags, perm);
-  int ret, cv_flags;
+  int fd, cv_flags;
   char * p;
 
   cv_flags = convert_flag_list(flags, open_flag_table);
-  p = stat_alloc(string_length(path) + 1);
+  p = caml_stat_alloc(string_length(path) + 1);
   strcpy(p, String_val(path));
   /* open on a named FIFO can block (PR#1533) */
   enter_blocking_section();
-  ret = open(p, cv_flags, Int_val(perm));
+  fd = open(p, cv_flags, Int_val(perm));
   leave_blocking_section();
   stat_free(p);
-  if (ret == -1) uerror("open", path);
-  CAMLreturn (Val_int(ret));
+  if (fd == -1) uerror("open", path);
+#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC)
+  if (convert_flag_list(flags, open_cloexec_table) != 0) {
+    int flags = fcntl(fd, F_GETFD, 0);
+    if (flags == -1 ||
+        fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
+      uerror("open", path);
+  }
+#endif
+  CAMLreturn (Val_int(fd));
 }
diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
index 7d7bdf9c..f70e708b 100644
--- a/otherlibs/unix/opendir.c
+++ b/otherlibs/unix/opendir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: opendir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c
index 868c80a2..7c6b1438 100644
--- a/otherlibs/unix/pipe.c
+++ b/otherlibs/unix/pipe.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: pipe.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c
index 5f709196..28ad962f 100644
--- a/otherlibs/unix/putenv.c
+++ b/otherlibs/unix/putenv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: putenv.c 12210 2012-03-08 19:52:03Z doligez $ */
-
 #include 
 #include 
 
diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c
index a77f3a52..3bbd0b47 100644
--- a/otherlibs/unix/read.c
+++ b/otherlibs/unix/read.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: read.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c
index d6c8a760..08dad1a0 100644
--- a/otherlibs/unix/readdir.c
+++ b/otherlibs/unix/readdir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: readdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
index 8a61f1c5..9534a42b 100644
--- a/otherlibs/unix/readlink.c
+++ b/otherlibs/unix/readlink.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: readlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
index fc94e957..2d34a883 100644
--- a/otherlibs/unix/rename.c
+++ b/otherlibs/unix/rename.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rename.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
index f35ffe80..17cc639f 100644
--- a/otherlibs/unix/rewinddir.c
+++ b/otherlibs/unix/rewinddir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rewinddir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
index 21140f67..631b47c0 100644
--- a/otherlibs/unix/rmdir.c
+++ b/otherlibs/unix/rmdir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rmdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c
index ad21804c..12d8cc55 100644
--- a/otherlibs/unix/select.c
+++ b/otherlibs/unix/select.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: select.c 12947 2012-09-24 11:25:32Z xleroy $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c
index 1a362ef0..679dde3c 100644
--- a/otherlibs/unix/sendrecv.c
+++ b/otherlibs/unix/sendrecv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sendrecv.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c
index 0b5aab49..8e635aa4 100644
--- a/otherlibs/unix/setgid.c
+++ b/otherlibs/unix/setgid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: setgid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/setgroups.c b/otherlibs/unix/setgroups.c
index 549a23e9..2279a6b3 100644
--- a/otherlibs/unix/setgroups.c
+++ b/otherlibs/unix/setgroups.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: setgroups.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -35,7 +33,7 @@ CAMLprim value unix_setgroups(value groups)
   int n;
 
   size = Wosize_val(groups);
-  gidset = (gid_t *) stat_alloc(size * sizeof(gid_t));
+  gidset = (gid_t *) caml_stat_alloc(size * sizeof(gid_t));
   for (i = 0; i < size; i++) gidset[i] = Int_val(Field(groups, i));
 
   n = setgroups(size, gidset);
diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c
index 1f3f761c..252b85c4 100644
--- a/otherlibs/unix/setsid.c
+++ b/otherlibs/unix/setsid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: setsid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c
index 70194d16..8a2a8074 100644
--- a/otherlibs/unix/setuid.c
+++ b/otherlibs/unix/setuid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: setuid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c
index 35c0eb8b..c428afbd 100644
--- a/otherlibs/unix/shutdown.c
+++ b/otherlibs/unix/shutdown.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: shutdown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
index 7b067d08..d4d97ef0 100644
--- a/otherlibs/unix/signals.c
+++ b/otherlibs/unix/signals.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: signals.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 
diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index 05500272..58affd39 100644
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sleep.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
index 77f9d76a..9e23231a 100644
--- a/otherlibs/unix/socket.c
+++ b/otherlibs/unix/socket.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socket.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
index ca38faa1..24babcab 100644
--- a/otherlibs/unix/socketaddr.c
+++ b/otherlibs/unix/socketaddr.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
index fb8080df..cf25e2f9 100644
--- a/otherlibs/unix/socketaddr.h
+++ b/otherlibs/unix/socketaddr.h
@@ -11,9 +11,7 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include 
+#include "misc.h"
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c
index fcabb11d..301ebf86 100644
--- a/otherlibs/unix/socketpair.c
+++ b/otherlibs/unix/socketpair.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketpair.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c
index bc406f09..b6167ebf 100644
--- a/otherlibs/unix/sockopt.c
+++ b/otherlibs/unix/sockopt.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sockopt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index 48d5ed84..a0f4c343 100644
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: stat.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
index 5668718d..5381bc31 100644
--- a/otherlibs/unix/strofaddr.c
+++ b/otherlibs/unix/strofaddr.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: strofaddr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -26,6 +24,29 @@ CAMLprim value unix_string_of_inet_addr(value a)
 {
   char * res;
 #ifdef HAS_IPV6
+#ifdef _WIN32
+  char buffer[64];
+  union sock_addr_union sa;
+  int len;
+  int retcode;
+  if (string_length(a) == 16) {
+    memset(&sa.s_inet6, 0, sizeof(struct sockaddr_in6));
+    sa.s_inet6.sin6_family = AF_INET6;
+    sa.s_inet6.sin6_addr = GET_INET6_ADDR(a);
+    len = sizeof(struct sockaddr_in6);
+  } else {
+    memset(&sa.s_inet, 0, sizeof(struct sockaddr_in));
+    sa.s_inet.sin_family = AF_INET;
+    sa.s_inet.sin_addr = GET_INET_ADDR(a);
+    len = sizeof(struct sockaddr_in);
+  }
+  retcode = getnameinfo
+    (&sa.s_gen, len, buffer, sizeof(buffer), NULL, 0, NI_NUMERICHOST);
+  if (retcode != 0)
+    res = NULL;
+  else
+    res = buffer;
+#else
   char buffer[64];
   if (string_length(a) == 16)
     res = (char *)
@@ -35,6 +56,7 @@ CAMLprim value unix_string_of_inet_addr(value a)
     res = (char *)
       inet_ntop(AF_INET, (const void *) &GET_INET_ADDR(a),
                 buffer, sizeof(buffer));
+#endif
 #else
   res = inet_ntoa(GET_INET_ADDR(a));
 #endif
diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
index 6028a8ea..26c9aa43 100644
--- a/otherlibs/unix/symlink.c
+++ b/otherlibs/unix/symlink.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: symlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c
index d793e7bb..9dd168ae 100644
--- a/otherlibs/unix/termios.c
+++ b/otherlibs/unix/termios.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: termios.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -265,11 +263,16 @@ CAMLprim value unix_tcsendbreak(value fd, value delay)
   return Val_unit;
 }
 
+#if defined(__ANDROID__)
+CAMLprim value unix_tcdrain(value fd)
+{ invalid_argument("tcdrain not implemented"); }
+#else
 CAMLprim value unix_tcdrain(value fd)
 {
   if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing);
   return Val_unit;
 }
+#endif
 
 static int queue_flag_table[] = {
   TCIFLUSH, TCOFLUSH, TCIOFLUSH
diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c
index 5ac5d8db..042a1f60 100644
--- a/otherlibs/unix/time.c
+++ b/otherlibs/unix/time.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: time.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c
index bd89432c..8ab6006d 100644
--- a/otherlibs/unix/times.c
+++ b/otherlibs/unix/times.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: times.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index 6c18a5d3..638ef799 100644
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: truncate.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c
index d3853215..311e4ed9 100644
--- a/otherlibs/unix/umask.c
+++ b/otherlibs/unix/umask.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: umask.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index 883050cc..8bd935f4 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml 12038 2012-01-18 09:28:05Z protzenk $ *)
-
 type error =
     E2BIG
   | EACCES
@@ -91,6 +89,83 @@ let _ = Callback.register_exception "Unix.Unix_error"
 
 external error_message : error -> string = "unix_error_message"
 
+let () =
+  Printexc.register_printer
+    (function
+      | Unix_error (e, s, s') ->
+          let msg = match e with
+          | E2BIG -> "E2BIG"
+          | EACCES -> "EACCES"
+          | EAGAIN -> "EAGAIN"
+          | EBADF -> "EBADF"
+          | EBUSY -> "EBUSY"
+          | ECHILD -> "ECHILD"
+          | EDEADLK -> "EDEADLK"
+          | EDOM -> "EDOM"
+          | EEXIST -> "EEXIST"
+          | EFAULT -> "EFAULT"
+          | EFBIG -> "EFBIG"
+          | EINTR -> "EINTR"
+          | EINVAL -> "EINVAL"
+          | EIO -> "EIO"
+          | EISDIR -> "EISDIR"
+          | EMFILE -> "EMFILE"
+          | EMLINK -> "EMLINK"
+          | ENAMETOOLONG -> "ENAMETOOLONG"
+          | ENFILE -> "ENFILE"
+          | ENODEV -> "ENODEV"
+          | ENOENT -> "ENOENT"
+          | ENOEXEC -> "ENOEXEC"
+          | ENOLCK -> "ENOLCK"
+          | ENOMEM -> "ENOMEM"
+          | ENOSPC -> "ENOSPC"
+          | ENOSYS -> "ENOSYS"
+          | ENOTDIR -> "ENOTDIR"
+          | ENOTEMPTY -> "ENOTEMPTY"
+          | ENOTTY -> "ENOTTY"
+          | ENXIO -> "ENXIO"
+          | EPERM -> "EPERM"
+          | EPIPE -> "EPIPE"
+          | ERANGE -> "ERANGE"
+          | EROFS -> "EROFS"
+          | ESPIPE -> "ESPIPE"
+          | ESRCH -> "ESRCH"
+          | EXDEV -> "EXDEV"
+          | EWOULDBLOCK -> "EWOULDBLOCK"
+          | EINPROGRESS -> "EINPROGRESS"
+          | EALREADY -> "EALREADY"
+          | ENOTSOCK -> "ENOTSOCK"
+          | EDESTADDRREQ -> "EDESTADDRREQ"
+          | EMSGSIZE -> "EMSGSIZE"
+          | EPROTOTYPE -> "EPROTOTYPE"
+          | ENOPROTOOPT -> "ENOPROTOOPT"
+          | EPROTONOSUPPORT -> "EPROTONOSUPPORT"
+          | ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT"
+          | EOPNOTSUPP -> "EOPNOTSUPP"
+          | EPFNOSUPPORT -> "EPFNOSUPPORT"
+          | EAFNOSUPPORT -> "EAFNOSUPPORT"
+          | EADDRINUSE -> "EADDRINUSE"
+          | EADDRNOTAVAIL -> "EADDRNOTAVAIL"
+          | ENETDOWN -> "ENETDOWN"
+          | ENETUNREACH -> "ENETUNREACH"
+          | ENETRESET -> "ENETRESET"
+          | ECONNABORTED -> "ECONNABORTED"
+          | ECONNRESET -> "ECONNRESET"
+          | ENOBUFS -> "ENOBUFS"
+          | EISCONN -> "EISCONN"
+          | ENOTCONN -> "ENOTCONN"
+          | ESHUTDOWN -> "ESHUTDOWN"
+          | ETOOMANYREFS -> "ETOOMANYREFS"
+          | ETIMEDOUT -> "ETIMEDOUT"
+          | ECONNREFUSED -> "ECONNREFUSED"
+          | EHOSTDOWN -> "EHOSTDOWN"
+          | EHOSTUNREACH -> "EHOSTUNREACH"
+          | ELOOP -> "ELOOP"
+          | EOVERFLOW -> "EOVERFLOW"
+          | EUNKNOWNERR x -> Printf.sprintf "EUNKNOWNERR %d" x in
+          Some (Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" msg s s')
+      | _ -> None)
+
 let handle_unix_error f arg =
   try
     f arg
@@ -127,7 +202,8 @@ external execvp : string -> string array -> 'a = "unix_execvp"
 external execvpe : string -> string array -> string array -> 'a = "unix_execvpe"
 external fork : unit -> int = "unix_fork"
 external wait : unit -> int * process_status = "unix_wait"
-external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid"
+external waitpid : wait_flag list -> int -> int * process_status
+   = "unix_waitpid"
 external getpid : unit -> int = "unix_getpid"
 external getppid : unit -> int = "unix_getppid"
 external nice : int -> int = "unix_nice"
@@ -152,6 +228,7 @@ type open_flag =
   | O_SYNC
   | O_RSYNC
   | O_SHARE_DELETE
+  | O_CLOEXEC
 
 type file_perm = int
 
@@ -162,7 +239,8 @@ external openfile : string -> open_flag list -> file_perm -> file_descr
 external close : file_descr -> unit = "unix_close"
 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
 external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
-external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int
+   = "unix_single_write"
 
 let read fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
@@ -231,7 +309,8 @@ external link : string -> string -> unit = "unix_link"
 
 module LargeFile =
   struct
-    external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
+    external lseek : file_descr -> int64 -> seek_command -> int64
+       = "unix_lseek_64"
     external truncate : string -> int64 -> unit = "unix_truncate_64"
     external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
     type stats =
@@ -762,6 +841,10 @@ external setsid : unit -> int = "unix_setsid"
 
 (* High-level process management (system, popen) *)
 
+let rec waitpid_non_intr pid =
+  try waitpid [] pid
+  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
+
 let system cmd =
   match fork() with
      0 -> begin try
@@ -769,7 +852,7 @@ let system cmd =
           with _ ->
             exit 127
           end
-  | id -> snd(waitpid [] id)
+  | id -> snd(waitpid_non_intr id)
 
 let rec safe_dup fd =
   let new_fd = dup fd in
@@ -922,10 +1005,6 @@ let find_proc_id fun_name proc =
   with Not_found ->
     raise(Unix_error(EBADF, fun_name, ""))
 
-let rec waitpid_non_intr pid =
-  try waitpid [] pid
-  with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
-
 let close_process_in inchan =
   let pid = find_proc_id "close_process_in" (Process_in inchan) in
   close_in inchan;
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index e6ba3e19..a483e425 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.mli 12140 2012-02-07 16:41:02Z doligez $ *)
-
 (** Interface to the Unix system *)
 
 
@@ -189,7 +187,8 @@ val waitpid : wait_flag list -> int -> int * process_status
    as the current process.
    Negative pid arguments represent process groups.
    The list of options indicates whether [waitpid] should return
-   immediately without waiting, or also report stopped children. *)
+   immediately without waiting, and whether it should report stopped
+   children. *)
 
 val system : string -> process_status
 (** Execute the given command, wait until it terminates, and return
@@ -243,6 +242,9 @@ type open_flag =
                                    O_SYNC/O_DSYNC) *)
   | O_SHARE_DELETE              (** Windows only: allow the file to be deleted
                                    while still open *)
+  | O_CLOEXEC                   (** Set the close-on-exec flag on the
+                                   descriptor returned by {!openfile} *)
+
 (** The flags to {!Unix.openfile}. *)
 
 
@@ -251,9 +253,9 @@ type file_perm = int
     read for group, none for others *)
 
 val openfile : string -> open_flag list -> file_perm -> file_descr
-(** Open the named file with the given flags. Third argument is
-   the permissions to give to the file if it is created. Return
-   a file descriptor on the named file. *)
+(** Open the named file with the given flags. Third argument is the
+   permissions to give to the file if it is created (see
+   {!umask}). Return a file descriptor on the named file. *)
 
 val close : file_descr -> unit
 (** Close a file descriptor. *)
@@ -307,7 +309,8 @@ type seek_command =
 
 
 val lseek : file_descr -> int -> seek_command -> int
-(** Set the current position for a file descriptor *)
+(** Set the current position for a file descriptor, and return the resulting
+    offset (from the beginning of the file). *)
 
 val truncate : string -> int -> unit
 (** Truncates the named file to the given size. *)
@@ -480,7 +483,7 @@ val clear_close_on_exec : file_descr -> unit
 
 
 val mkdir : string -> file_perm -> unit
-(** Create a directory with the given permissions. *)
+(** Create a directory with the given permissions (see {!umask}). *)
 
 val rmdir : string -> unit
 (** Remove an empty directory. *)
@@ -521,7 +524,7 @@ val pipe : unit -> file_descr * file_descr
    opened for writing, that's the entrance to the pipe. *)
 
 val mkfifo : string -> file_perm -> unit
-(** Create a named pipe with the given permissions. *)
+(** Create a named pipe with the given permissions (see {!umask}). *)
 
 
 (** {6 High-level process and redirection management} *)
diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml
index ef364889..1bd410bd 100644
--- a/otherlibs/unix/unixLabels.ml
+++ b/otherlibs/unix/unixLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unixLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [UnixLabels]: labelled Unix module *)
 
 include Unix
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index e5b073aa..4dc411b0 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unixLabels.mli 11307 2011-12-13 17:59:10Z frisch $ *)
-
 (** Interface to the Unix system.
    To use as replacement to default {!Unix} module,
    add [module Unix = UnixLabels] in your implementation.
@@ -185,7 +183,8 @@ val wait : unit -> int * process_status
    and termination status. *)
 
 val waitpid : mode:wait_flag list -> int -> int * process_status
-(** Same as {!UnixLabels.wait}, but waits for the child process whose pid is given.
+(** Same as {!UnixLabels.wait}, but waits for the child process whose pid
+   is given.
    A pid of [-1] means wait for any child.
    A pid of [0] means wait for any child in the same process group
    as the current process.
@@ -241,6 +240,8 @@ type open_flag = Unix.open_flag =
   | O_SYNC                      (** Writes complete as `Synchronised I/O file integrity completion' *)
   | O_RSYNC                     (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
   | O_SHARE_DELETE              (** Windows only: allow the file to be deleted while still open *)
+  | O_CLOEXEC                   (** Set the close-on-exec flag on the
+                                   descriptor returned by {!openfile} *)
 (** The flags to {!UnixLabels.openfile}. *)
 
 
@@ -305,7 +306,8 @@ type seek_command = Unix.seek_command =
 
 
 val lseek : file_descr -> int -> mode:seek_command -> int
-(** Set the current position for a file descriptor *)
+(** Set the current position for a file descriptor, and return the resulting
+    offset (from the beginning of the file). *)
 
 val truncate : string -> len:int -> unit
 (** Truncates the named file to the given size. *)
diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
index 34891ecc..f1df3fc7 100644
--- a/otherlibs/unix/unixsupport.c
+++ b/otherlibs/unix/unixsupport.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.c 11915 2011-12-21 13:08:48Z protzenk $ */
-
 #include 
 #include 
 #include 
@@ -272,6 +270,15 @@ value unix_error_of_code (int errcode)
   return err;
 }
 
+extern int code_of_unix_error (value error)
+{
+  if (Is_block(error)) {
+    return Int_val(Field(error, 0));
+  } else {
+    return error_table[Int_val(error)];
+  }
+}
+
 void unix_error(int errcode, char *cmdname, value cmdarg)
 {
   value res;
@@ -284,7 +291,8 @@ void unix_error(int errcode, char *cmdname, value cmdarg)
     if (unix_error_exn == NULL) {
       unix_error_exn = caml_named_value("Unix.Unix_error");
       if (unix_error_exn == NULL)
-        invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
+        invalid_argument("Exception Unix.Unix_error not initialized,"
+                         " please link unix.cma");
     }
     res = alloc_small(4, 0);
     Field(res, 0) = *unix_error_exn;
diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
index f561ce66..a8065d97 100644
--- a/otherlibs/unix/unixsupport.h
+++ b/otherlibs/unix/unixsupport.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.h 12488 2012-05-28 11:31:30Z frisch $ */
-
 #ifdef HAS_UNISTD
 #include 
 #endif
@@ -20,6 +18,7 @@
 #define Nothing ((value) 0)
 
 extern value unix_error_of_code (int errcode);
+extern int code_of_unix_error (value error);
 extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
 extern void uerror (char * cmdname, value arg) Noreturn;
 
diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
index 8913e397..76ec9131 100644
--- a/otherlibs/unix/unlink.c
+++ b/otherlibs/unix/unlink.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unlink.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
index ed969897..825fc4cd 100644
--- a/otherlibs/unix/utimes.c
+++ b/otherlibs/unix/utimes.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: utimes.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
index 10cf826f..81f36839 100644
--- a/otherlibs/unix/wait.c
+++ b/otherlibs/unix/wait.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: wait.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
index 63533621..d6fe4093 100644
--- a/otherlibs/unix/write.c
+++ b/otherlibs/unix/write.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: write.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 62c4678c..f09392ed 100644
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 LIBNAME=graphics
 COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O)
 CAMLOBJS=graphics.cmo
diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c
index 36904368..100beba3 100644
--- a/otherlibs/win32graph/dib.c
+++ b/otherlibs/win32graph/dib.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dib.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 //-----------------------------------------------------------------------------
 // DIB.C
 //
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index f20e8165..fc6cf102 100644
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: draw.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "mlvalues.h"
 #include "alloc.h"
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
index 59f0b91b..81242729 100755
--- a/otherlibs/win32graph/events.c
+++ b/otherlibs/win32graph/events.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: events.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "mlvalues.h"
 #include "alloc.h"
 #include "libgraph.h"
diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h
index a041dfa7..99ede995 100644
--- a/otherlibs/win32graph/libgraph.h
+++ b/otherlibs/win32graph/libgraph.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: libgraph.h 12149 2012-02-10 16:15:24Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index a0247061..5e62da5d 100644
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c 12149 2012-02-10 16:15:24Z doligez $ */
-
 #include 
 #include 
 #include "mlvalues.h"
@@ -101,6 +99,7 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM
                 // End application
         case WM_DESTROY:
                 ResetForClose(hwnd);
+		gr_check_open();
                 break;
         }
         caml_gr_handle_event(msg, wParam, lParam);
diff --git a/otherlibs/win32unix/.ignore b/otherlibs/win32unix/.ignore
index e85bbd9a..1eac7a1f 100644
--- a/otherlibs/win32unix/.ignore
+++ b/otherlibs/win32unix/.ignore
@@ -12,9 +12,11 @@ execv.c
 execve.c
 execvp.c
 exit.c
+getaddrinfo.c
 getcwd.c
 gethost.c
 gethostname.c
+getnameinfo.c
 getproto.c
 getserv.c
 gmtime.c
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 76a1c19f..77555b2c 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11912 2011-12-21 09:43:13Z protzenk $
-
 # 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 \
@@ -27,7 +25,8 @@ 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 \
-  exit.c getcwd.c gethost.c gethostname.c getproto.c \
+  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
+  getnameinfo.c getproto.c \
   getserv.c gmtime.c putenv.c rmdir.c \
   socketaddr.c strofaddr.c time.c unlink.c utimes.c
 
diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
index e67eea47..f2e14467 100644
--- a/otherlibs/win32unix/accept.c
+++ b/otherlibs/win32unix/accept.c
@@ -11,13 +11,12 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: accept.c 12480 2012-05-24 16:40:59Z xleroy $ */
-
 #include 
 #include 
 #include 
 #include 
 #include "unixsupport.h"
+#include    // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT
 #include "socketaddr.h"
 
 CAMLprim value unix_accept(sock)
diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c
index eab979cc..bc092308 100644
--- a/otherlibs/win32unix/bind.c
+++ b/otherlibs/win32unix/bind.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bind.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include "socketaddr.h"
diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index 626376bc..1e7e823a 100644
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: channels.c 11927 2011-12-21 16:31:01Z xleroy $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c
index 92600b93..20b131b0 100644
--- a/otherlibs/win32unix/close.c
+++ b/otherlibs/win32unix/close.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: close.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include 
diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c
index 00c93f85..9ba342ed 100644
--- a/otherlibs/win32unix/close_on.c
+++ b/otherlibs/win32unix/close_on.c
@@ -11,11 +11,9 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: close_on.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include 
-#include 
 #include "unixsupport.h"
+#include 
 
 int win_set_inherit(value fd, BOOL inherit)
 {
diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c
index 628ed853..190eb742 100644
--- a/otherlibs/win32unix/connect.c
+++ b/otherlibs/win32unix/connect.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: connect.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
index 48c0a746..4e32cb19 100644
--- a/otherlibs/win32unix/createprocess.c
+++ b/otherlibs/win32unix/createprocess.c
@@ -11,12 +11,10 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: createprocess.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include 
 #include 
-#include 
 #include "unixsupport.h"
+#include 
+#include 
 
 static int win_has_console(void);
 
diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c
index 2525df73..76cbdf67 100644
--- a/otherlibs/win32unix/dup.c
+++ b/otherlibs/win32unix/dup.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dup.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c
index 4c146a50..5f19710c 100644
--- a/otherlibs/win32unix/dup2.c
+++ b/otherlibs/win32unix/dup2.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: dup2.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
index 19ea3d72..c3bc19c6 100644
--- a/otherlibs/win32unix/errmsg.c
+++ b/otherlibs/win32unix/errmsg.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: errmsg.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c
index cdd8aebe..ad6674bf 100644
--- a/otherlibs/win32unix/getpeername.c
+++ b/otherlibs/win32unix/getpeername.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpeername.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include "socketaddr.h"
diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c
index b488e9ac..65c8828a 100644
--- a/otherlibs/win32unix/getpid.c
+++ b/otherlibs/win32unix/getpid.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getpid.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c
index 914bfaaf..1e28f4b2 100644
--- a/otherlibs/win32unix/getsockname.c
+++ b/otherlibs/win32unix/getsockname.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: getsockname.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 #include "socketaddr.h"
diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
index b8433c37..573821fd 100644
--- a/otherlibs/win32unix/gettimeofday.c
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -11,23 +11,41 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gettimeofday.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
 
 #include "unixsupport.h"
 
+#ifdef HAS_MKTIME
+static double initial_time = 0; /* 0 means uninitialized */
+#else
 static time_t initial_time = 0; /* 0 means uninitialized */
+#endif
 static DWORD initial_tickcount;
 
 CAMLprim value unix_gettimeofday(value unit)
 {
   DWORD tickcount = GetTickCount();
+  SYSTEMTIME st;
+  struct tm tm;
   if (initial_time == 0 || tickcount < initial_tickcount) {
     initial_tickcount = tickcount;
+#ifdef HAS_MKTIME
+    GetLocalTime(&st);
+    tm.tm_sec = st.wSecond;
+    tm.tm_min = st.wMinute;
+    tm.tm_hour = st.wHour;
+    tm.tm_mday = st.wDay;
+    tm.tm_mon = st.wMonth - 1;
+    tm.tm_year = st.wYear - 1900;
+    tm.tm_wday = 0;
+    tm.tm_yday = 0;
+    tm.tm_isdst = -1;
+    initial_time = ((double) mktime(&tm) + (double) st.wMilliseconds * 1e-3);
+#else
     initial_time = time(NULL);
+#endif
     return copy_double((double) initial_time);
   } else {
     return copy_double((double) initial_time +
diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
index 34f841a5..97748ba2 100644
--- a/otherlibs/win32unix/link.c
+++ b/otherlibs/win32unix/link.c
@@ -11,12 +11,10 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: link.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include 
 #include 
 #include 
 #include "unixsupport.h"
+#include 
 
 typedef
 BOOL (WINAPI *tCreateHardLink)(
diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c
index 4926842b..9602a373 100644
--- a/otherlibs/win32unix/listen.c
+++ b/otherlibs/win32unix/listen.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: listen.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c
index e7858546..6e6ca0ad 100644
--- a/otherlibs/win32unix/lockf.c
+++ b/otherlibs/win32unix/lockf.c
@@ -13,8 +13,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: lockf.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
@@ -64,7 +62,8 @@ CAMLprim value unix_lockf(value fd, value cmd, value span)
 
   version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
   if(GetVersionEx(&version) == 0) {
-    invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform.");
+    invalid_argument("lockf only supported on WIN32_NT platforms:"
+                     " could not determine current platform.");
   }
   if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
     invalid_argument("lockf only supported on WIN32_NT platforms");
diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
index aa01dc58..5306331c 100644
--- a/otherlibs/win32unix/lseek.c
+++ b/otherlibs/win32unix/lseek.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: lseek.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
index abd6094e..998b32ba 100644
--- a/otherlibs/win32unix/mkdir.c
+++ b/otherlibs/win32unix/mkdir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mkdir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c
index 7bb8a3a9..a9aaeca5 100755
--- a/otherlibs/win32unix/nonblock.c
+++ b/otherlibs/win32unix/nonblock.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: nonblock.c 11223 2011-10-15 09:02:22Z xleroy $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
index b4a5d716..afb8d0fb 100644
--- a/otherlibs/win32unix/open.c
+++ b/otherlibs/win32unix/open.c
@@ -11,34 +11,37 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: open.c 11305 2011-12-13 16:21:10Z frisch $ */
-
 #include 
 #include 
 #include "unixsupport.h"
 #include 
 
-static int open_access_flags[13] = {
+static int open_access_flags[14] = {
   GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
-  0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+};
+
+static int open_create_flags[14] = {
+  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0
 };
 
-static int open_create_flags[13] = {
-  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0
+static int open_share_flags[14] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0
 };
 
-static int open_share_flags[13] = {
-  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE
+static int open_cloexec_flags[14] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
 };
 
 CAMLprim value unix_open(value path, value flags, value perm)
 {
-  int fileaccess, createflags, fileattrib, filecreate, sharemode;
+  int fileaccess, createflags, fileattrib, filecreate, sharemode, cloexec;
   SECURITY_ATTRIBUTES attr;
   HANDLE h;
 
   fileaccess = convert_flag_list(flags, open_access_flags);
-  sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE | convert_flag_list(flags, open_share_flags);
+  sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE
+              | convert_flag_list(flags, open_share_flags);
 
   createflags = convert_flag_list(flags, open_create_flags);
   if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
@@ -57,9 +60,10 @@ CAMLprim value unix_open(value path, value flags, value perm)
   else
     fileattrib = FILE_ATTRIBUTE_NORMAL;
 
+  cloexec = convert_flag_list(flags, open_cloexec_flags);
   attr.nLength = sizeof(attr);
   attr.lpSecurityDescriptor = NULL;
-  attr.bInheritHandle = TRUE;
+  attr.bInheritHandle = cloexec ? FALSE : TRUE;
 
   h = CreateFile(String_val(path), fileaccess,
                  sharemode, &attr,
diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c
index fc9069be..fe553778 100644
--- a/otherlibs/win32unix/pipe.c
+++ b/otherlibs/win32unix/pipe.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: pipe.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c
index 41e55423..e7a2b38d 100644
--- a/otherlibs/win32unix/read.c
+++ b/otherlibs/win32unix/read.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: read.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index b8a33373..b8c0f3ed 100644
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: rename.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index e9169dfa..9f06024f 100644
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -11,19 +11,14 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: select.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include 
 #include 
 #include 
 #include 
 #include 
-#include 
-#include 
+#include "winworker.h"
 #include 
-#include "unixsupport.h"
 #include "windbug.h"
-#include "winworker.h"
 #include "winlist.h"
 
 /* This constant define the maximum number of objects that
diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c
index 9d4c32c4..f2745fb1 100644
--- a/otherlibs/win32unix/sendrecv.c
+++ b/otherlibs/win32unix/sendrecv.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sendrecv.c 11896 2011-12-20 12:37:52Z xleroy $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c
index 73a4afa7..2d5707a3 100644
--- a/otherlibs/win32unix/shutdown.c
+++ b/otherlibs/win32unix/shutdown.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: shutdown.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "unixsupport.h"
 
diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 5e853f16..28e60e40 100644
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sleep.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include "unixsupport.h"
diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
index c979261f..ad8165b2 100644
--- a/otherlibs/win32unix/socket.c
+++ b/otherlibs/win32unix/socket.c
@@ -11,13 +11,17 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socket.c 12480 2012-05-24 16:40:59Z xleroy $ */
-
 #include 
 #include "unixsupport.h"
+#include    // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT
 
 int socket_domain_table[] = {
-  PF_UNIX, PF_INET /*, PF_INET6 */
+  PF_UNIX, PF_INET,
+#if defined(HAS_IPV6)
+  PF_INET6
+#else
+  0
+#endif
 };
 
 int socket_type_table[] = {
@@ -30,11 +34,14 @@ CAMLprim value unix_socket(domain, type, proto)
   SOCKET s;
   int oldvalue, oldvaluelen, newvalue, retcode;
 
+  #ifndef HAS_IPV6
   /* IPv6 requires WinSock2, we must raise an error on PF_INET6 */
   if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) {
     win32_maperr(WSAEPFNOSUPPORT);
     uerror("socket", Nothing);
   }
+  #endif
+
   oldvaluelen = sizeof(oldvalue);
   retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
                        (char *) &oldvalue, &oldvaluelen);
diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
index 54425374..fde691ec 100644
--- a/otherlibs/win32unix/socketaddr.h
+++ b/otherlibs/win32unix/socketaddr.h
@@ -11,13 +11,14 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: socketaddr.h 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include 
+#include "misc.h"
 
 union sock_addr_union {
   struct sockaddr s_gen;
   struct sockaddr_in s_inet;
+#ifdef HAS_IPV6
+  struct sockaddr_in6 s_inet6;
+#endif
 };
 
 extern union sock_addr_union sock_addr;
@@ -35,3 +36,8 @@ CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/,
                       socklen_param_type addr_len, int close_on_error);
 CAMLprim value alloc_inet_addr (struct in_addr * inaddr);
 #define GET_INET_ADDR(v) (*((struct in_addr *) (v)))
+
+#ifdef HAS_IPV6
+CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr);
+#define GET_INET6_ADDR(v) (*((struct in6_addr *) (v)))
+#endif
diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c
index eabab49e..eefa9a30 100644
--- a/otherlibs/win32unix/sockopt.c
+++ b/otherlibs/win32unix/sockopt.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sockopt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c
index 8d4def6c..65aedc6a 100644
--- a/otherlibs/win32unix/startup.c
+++ b/otherlibs/win32unix/startup.c
@@ -15,7 +15,6 @@
 #include 
 #include 
 #include 
-#include "unixsupport.h"
 #include "winworker.h"
 #include "windbug.h"
 
diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index d1cfdbb7..56b45d03 100644
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: stat.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
index 1d9a234b..13d5658e 100644
--- a/otherlibs/win32unix/system.c
+++ b/otherlibs/win32unix/system.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: system.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
index 1946452d..e6b5ab0a 100644
--- a/otherlibs/win32unix/times.c
+++ b/otherlibs/win32unix/times.c
@@ -1,6 +1,20 @@
-#include 
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                 File contributed by Josh Berdine                    */
+/*                                                                     */
+/*  Copyright 2011 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../../LICENSE.  */
+/*                                                                     */
+/***********************************************************************/
+
 #include 
+#include 
 #include "unixsupport.h"
+#include 
 
 
 double to_sec(FILETIME ft) {
@@ -16,11 +30,11 @@ double to_sec(FILETIME ft) {
 
 
 value unix_times(value unit) {
-
   value res;
   FILETIME creation, exit, stime, utime;
 
-  if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {
+  if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime,
+                        &utime))) {
     win32_maperr(GetLastError());
     uerror("times", Nothing);
   }
@@ -31,5 +45,4 @@ value unix_times(value unit) {
   Store_double_field(res, 2, 0);
   Store_double_field(res, 3, 0);
   return res;
-
 }
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 3a607f17..2a9b0802 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: unix.ml 11912 2011-12-21 09:43:13Z protzenk $ *)
-
 (* Initialization *)
 
 external startup: unit -> unit = "win_startup"
@@ -171,6 +169,7 @@ type open_flag =
   | O_SYNC
   | O_RSYNC
   | O_SHARE_DELETE
+  | O_CLOEXEC
 
 type file_perm = int
 
@@ -199,10 +198,14 @@ let single_write fd buf ofs len =
 
 (* Interfacing with the standard input/output library *)
 
-external in_channel_of_descr: file_descr -> in_channel = "win_inchannel_of_filedescr"
-external out_channel_of_descr: file_descr -> out_channel = "win_outchannel_of_filedescr"
-external descr_of_in_channel : in_channel -> file_descr = "win_filedescr_of_channel"
-external descr_of_out_channel : out_channel -> file_descr = "win_filedescr_of_channel"
+external in_channel_of_descr: file_descr -> in_channel
+   = "win_inchannel_of_filedescr"
+external out_channel_of_descr: file_descr -> out_channel
+   = "win_outchannel_of_filedescr"
+external descr_of_in_channel : in_channel -> file_descr
+   = "win_filedescr_of_channel"
+external descr_of_out_channel : out_channel -> file_descr
+   = "win_filedescr_of_channel"
 
 (* Seeking and truncating *)
 
@@ -257,9 +260,12 @@ external link : string -> string -> unit = "unix_link"
 
 module LargeFile =
   struct
-    external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
-    let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented"
-    let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented"
+    external lseek : file_descr -> int64 -> seek_command -> int64
+       = "unix_lseek_64"
+    let truncate name len =
+      invalid_arg "Unix.LargeFile.truncate not implemented"
+    let ftruncate name len =
+      invalid_arg "Unix.LargeFile.ftruncate not implemented"
     type stats =
       { st_dev : int;
         st_ino : int;
@@ -658,7 +664,11 @@ type getaddrinfo_option =
   | AI_CANONNAME
   | AI_PASSIVE
 
-let getaddrinfo node service opts =
+external getaddrinfo_system
+  : string -> string -> getaddrinfo_option list -> addr_info list
+  = "unix_getaddrinfo"
+
+let getaddrinfo_emulation node service opts =
   (* Parse options *)
   let opt_socktype = ref None
   and opt_protocol = ref 0
@@ -720,6 +730,12 @@ let getaddrinfo node service opts =
           addresses)
       ports)
 
+let getaddrinfo node service opts =
+  try
+    List.rev(getaddrinfo_system node service opts)
+  with Invalid_argument _ ->
+    getaddrinfo_emulation node service opts
+
 type name_info =
   { ni_hostname : string;
     ni_service : string }
@@ -731,7 +747,11 @@ type getnameinfo_option =
   | NI_NUMERICSERV
   | NI_DGRAM
 
-let getnameinfo addr opts =
+external getnameinfo_system
+  : sockaddr -> getnameinfo_option list -> name_info
+  = "unix_getnameinfo"
+
+let getnameinfo_emulation addr opts =
   match addr with
   | ADDR_UNIX f ->
       { ni_hostname = ""; ni_service = f } (* why not? *)
@@ -752,6 +772,12 @@ let getnameinfo addr opts =
           string_of_int p in
       { ni_hostname = hostname; ni_service = service }
 
+let getnameinfo addr opts =
+  try
+    getnameinfo_system addr opts
+  with Invalid_argument _ ->
+    getnameinfo_emulation addr opts
+
 (* High-level process management (system, popen) *)
 
 external win_create_process : string -> string -> string option ->
@@ -874,12 +900,14 @@ external select :
 (* High-level network functions *)
 
 let open_connection sockaddr =
-  let domain =
-    match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in
   let sock =
-    socket domain SOCK_STREAM 0 in
-  connect sock sockaddr;
-  (in_channel_of_descr sock, out_channel_of_descr sock)
+    socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
+  try
+    connect sock sockaddr;
+    set_close_on_exec sock;
+    (in_channel_of_descr sock, out_channel_of_descr sock)
+  with exn ->
+    close sock; raise exn
 
 let shutdown_connection inchan =
   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index d94bc2da..f954dfc9 100644
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.c 11223 2011-10-15 09:02:22Z xleroy $ */
-
 #include 
 #include 
 #include 
@@ -257,7 +255,8 @@ void unix_error(int errcode, char *cmdname, value cmdarg)
     if (unix_error_exn == NULL) {
       unix_error_exn = caml_named_value("Unix.Unix_error");
       if (unix_error_exn == NULL)
-        invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
+        invalid_argument("Exception Unix.Unix_error not initialized,"
+                         " please link unix.cma");
     }
     res = alloc_small(4, 0);
     Field(res, 0) = *unix_error_exn;
diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
index dc99fe20..b8f8acad 100644
--- a/otherlibs/win32unix/unixsupport.h
+++ b/otherlibs/win32unix/unixsupport.h
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: unixsupport.h 12488 2012-05-28 11:31:30Z frisch $ */
-
 #define WIN32_LEAN_AND_MEAN
 #include 
 #include 
@@ -20,7 +18,11 @@
 #include 
 #include 
 #include 
-#include 
+#include 
+#ifdef HAS_IPV6
+#include 
+#include 
+#endif
 
 struct filedescr {
   union {
diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c
index ffbfaca9..a5e0d649 100644
--- a/otherlibs/win32unix/windbug.c
+++ b/otherlibs/win32unix/windbug.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: windbug.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include "windbug.h"
 
 int debug_test (void)
diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index aba45ead..eb7c94f1 100644
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -11,21 +11,21 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: windbug.h 12023 2012-01-14 09:40:49Z xleroy $ */
-
 #ifdef DEBUG
 
 #include 
 #include 
 
-/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty argument lists)
+/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty
+   argument lists)
  */
 #define DEBUG_PRINT(fmt, ...) \
   do \
   { \
     if (debug_test()) \
     { \
-      fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), GetCurrentThreadId()); \
+      fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), \
+              GetCurrentThreadId()); \
       fprintf(stderr, fmt, ##__VA_ARGS__); \
       fprintf(stderr, "\n"); \
       fflush(stderr); \
diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c
index eb744195..7a08e510 100644
--- a/otherlibs/win32unix/windir.c
+++ b/otherlibs/win32unix/windir.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: windir.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/otherlibs/win32unix/winlist.c b/otherlibs/win32unix/winlist.c
index 1842558f..3c80b334 100644
--- a/otherlibs/win32unix/winlist.c
+++ b/otherlibs/win32unix/winlist.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: winlist.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* Basic list function in C. */
 
 #include "winlist.h"
diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h
index 8950abdd..8b35c551 100644
--- a/otherlibs/win32unix/winlist.h
+++ b/otherlibs/win32unix/winlist.h
@@ -11,7 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: winlist.h 11156 2011-07-27 14:17:02Z doligez $ */
 #ifndef _WINLIST_H
 #define _WINLIST_H
 
diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
index a2ac232e..0436072f 100644
--- a/otherlibs/win32unix/winwait.c
+++ b/otherlibs/win32unix/winwait.c
@@ -11,15 +11,13 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: winwait.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#include 
 #include 
 #include 
 #include 
+#include 
 #include "unixsupport.h"
+#include 
 #include 
-#include 
 
 static value alloc_process_status(HANDLE pid, int status)
 {
diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c
index ab47d582..f8ef33e1 100644
--- a/otherlibs/win32unix/winworker.c
+++ b/otherlibs/win32unix/winworker.c
@@ -11,14 +11,13 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: winworker.c 11156 2011-07-27 14:17:02Z doligez $ */
-
+#include 
+#include 
+#include 
+#include 
 #include "winworker.h"
 #include "winlist.h"
 #include "windbug.h"
-#include 
-#include 
-#include "unixsupport.h"
 
 typedef enum {
   WORKER_CMD_NONE = 0,
@@ -28,10 +27,11 @@ typedef enum {
 
 struct _WORKER {
   LIST       lst;           /* This structure is used as a list. */
-  HANDLE     hJobStarted;   /* Event representing that the function has begun. */
-  HANDLE     hJobStop;      /* Event that can be used to notify the function that it
-                               should stop processing. */
-  HANDLE     hJobDone;      /* Event representing that the function has finished. */
+  HANDLE     hJobStarted;   /* Event representing that the function has begun.*/
+  HANDLE     hJobStop;      /* Event that can be used to notify the function
+                               that it should stop processing. */
+  HANDLE     hJobDone;      /* Event representing that the function has
+                               finished. */
   void      *lpJobUserData; /* User data for the job. */
   WORKERFUNC hJobFunc;      /* Function to be called during APC */
   HANDLE     hWorkerReady;  /* Worker is ready. */
diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h
index 7544a98c..cb9bf4f8 100644
--- a/otherlibs/win32unix/winworker.h
+++ b/otherlibs/win32unix/winworker.h
@@ -11,11 +11,11 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: winworker.h 11156 2011-07-27 14:17:02Z doligez $ */
 #ifndef _WINWORKER_H
 #define _WINWORKER_H
 
 #define _WIN32_WINNT 0x0400
+#include "unixsupport.h"
 #include 
 
 /* Pool of worker threads.
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
index 849f6d2d..65f82ccb 100644
--- a/otherlibs/win32unix/write.c
+++ b/otherlibs/win32unix/write.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: write.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
new file mode 100644
index 00000000..1584e2e3
--- /dev/null
+++ b/parsing/ast_mapper.ml
@@ -0,0 +1,566 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* A generic Parsetree mapping class *)
+
+open Location
+open Config
+open Parsetree
+open Asttypes
+
+(* First, some helpers to build AST fragments *)
+
+let map_flatten f l = List.flatten (List.map f l)
+let map_snd f (x, y) = (x, f y)
+let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let map_loc sub {loc; txt} = {loc = sub # location loc; txt}
+
+module T = struct
+  (* Type expressions for the core language *)
+
+  let mk ?(loc = Location.none) x = {ptyp_desc = x; ptyp_loc = loc}
+  let any ?loc () = mk ?loc Ptyp_any
+  let var ?loc a = mk ?loc (Ptyp_var a)
+  let arrow ?loc a b c = mk ?loc (Ptyp_arrow (a, b, c))
+  let tuple ?loc a = mk ?loc (Ptyp_tuple a)
+  let constr ?loc a b = mk ?loc (Ptyp_constr (a, b))
+  let object_ ?loc a = mk ?loc (Ptyp_object a)
+  let class_ ?loc a b c = mk ?loc (Ptyp_class (a, b, c))
+  let alias ?loc a b = mk ?loc (Ptyp_alias (a, b))
+  let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c))
+  let poly ?loc a b = mk ?loc (Ptyp_poly (a, b))
+  let package ?loc a b = mk ?loc (Ptyp_package (a, b))
+
+  let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc}
+  let field ?loc s t =
+    let t =
+      (* The type-checker expects the field to be a Ptyp_poly. Maybe
+         it should wrap the type automatically... *)
+      match t.ptyp_desc with
+      | Ptyp_poly _ -> t
+      | _ -> poly ?loc [] t
+    in
+    field_type ?loc (Pfield (s, t))
+  let field_var ?loc () = field_type ?loc Pfield_var
+
+  let core_field_type sub {pfield_desc = desc; pfield_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pfield (s, d) -> field ~loc:(sub # location loc) s (sub # typ d)
+    | Pfield_var -> field_var ~loc ()
+
+  let row_field sub = function
+    | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
+    | Rinherit t -> Rinherit (sub # typ t)
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Ptyp_any -> any ~loc ()
+    | Ptyp_var s -> var ~loc s
+    | Ptyp_arrow (lab, t1, t2) -> arrow ~loc lab (sub # typ t1) (sub # typ t2)
+    | Ptyp_tuple tyl -> tuple ~loc (List.map (sub # typ) tyl)
+    | Ptyp_constr (lid, tl) ->
+        constr ~loc (map_loc sub lid) (List.map (sub # typ) tl)
+    | Ptyp_object l -> object_ ~loc (List.map (core_field_type sub) l)
+    | Ptyp_class (lid, tl, ll) ->
+        class_ ~loc (map_loc sub lid) (List.map (sub # typ) tl) ll
+    | Ptyp_alias (t, s) -> alias ~loc (sub # typ t) s
+    | Ptyp_variant (rl, b, ll) ->
+        variant ~loc (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t)
+    | Ptyp_package (lid, l) ->
+        package ~loc (map_loc sub lid)
+                (List.map (map_tuple (map_loc sub) (sub # typ)) l)
+
+  let map_type_declaration sub td =
+    {td with
+     ptype_cstrs =
+     List.map
+       (fun (ct1, ct2, loc) -> sub # typ ct1, sub # typ ct2, sub # location loc)
+       td.ptype_cstrs;
+     ptype_kind = sub # type_kind td.ptype_kind;
+     ptype_manifest = map_opt (sub # typ) td.ptype_manifest;
+     ptype_loc = sub # location td.ptype_loc;
+    }
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l ->
+        let f (s, tl, t, loc) =
+          (map_loc sub s,
+           List.map (sub # typ) tl,
+           map_opt (sub # typ) t,
+           sub # location loc)
+        in
+        Ptype_variant (List.map f l)
+    | Ptype_record l ->
+        let f (s, flags, t, loc) =
+          (map_loc sub s, flags, sub # typ t, sub # location loc)
+        in
+        Ptype_record (List.map f l)
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let mk ?(loc = Location.none) x = {pcty_loc = loc; pcty_desc = x}
+
+  let constr ?loc a b = mk ?loc (Pcty_constr (a, b))
+  let signature ?loc a = mk ?loc (Pcty_signature a)
+  let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c))
+
+  let map sub {pcty_loc = loc; pcty_desc = desc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pcty_constr (lid, tys) ->
+        constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
+    | Pcty_signature x -> signature ~loc (sub # class_signature x)
+    | Pcty_fun (lab, t, ct) ->
+        fun_ ~loc lab
+          (sub # typ t)
+          (sub # class_type ct)
+
+  let mk_field ?(loc = Location.none) x = {pctf_desc = x; pctf_loc = loc}
+
+  let inher ?loc a = mk_field ?loc (Pctf_inher a)
+  let val_ ?loc a b c d = mk_field ?loc (Pctf_val (a, b, c, d))
+  let virt ?loc a b c = mk_field ?loc (Pctf_virt (a, b, c))
+  let meth ?loc a b c = mk_field ?loc (Pctf_meth (a, b, c))
+  let cstr ?loc a b = mk_field ?loc (Pctf_cstr (a, b))
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pctf_inher ct -> inher ~loc (sub # class_type ct)
+    | Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
+    | Pctf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
+    | Pctf_meth (s, p, t) -> meth ~loc s p (sub # typ t)
+    | Pctf_cstr (t1, t2) -> cstr ~loc (sub # typ t1) (sub # typ t2)
+
+  let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
+    {
+     pcsig_self = sub # typ pcsig_self;
+     pcsig_fields = List.map (sub # class_type_field) pcsig_fields;
+     pcsig_loc = sub # location pcsig_loc ;
+    }
+end
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let mk ?(loc = Location.none) x = {pmty_desc = x; pmty_loc = loc}
+  let ident ?loc a = mk ?loc (Pmty_ident a)
+  let signature ?loc a = mk ?loc (Pmty_signature a)
+  let functor_ ?loc a b c = mk ?loc (Pmty_functor (a, b, c))
+  let with_ ?loc a b = mk ?loc (Pmty_with (a, b))
+  let typeof_ ?loc a = mk ?loc (Pmty_typeof a)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pmty_ident s -> ident ~loc (map_loc sub s)
+    | Pmty_signature sg -> signature ~loc (sub # signature sg)
+    | Pmty_functor (s, mt1, mt2) ->
+        functor_ ~loc (map_loc sub s) (sub # module_type mt1)
+                 (sub # module_type mt2)
+    | Pmty_with (mt, l) ->
+        with_ ~loc (sub # module_type mt)
+              (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l)
+    | Pmty_typeof me -> typeof_ ~loc (sub # module_expr me)
+
+  let map_with_constraint sub = function
+    | Pwith_type d -> Pwith_type (sub # type_declaration d)
+    | Pwith_module s -> Pwith_module (map_loc sub s)
+    | Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
+    | Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
+
+  let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
+
+  let value ?loc a b = mk_item ?loc (Psig_value (a, b))
+  let type_ ?loc a = mk_item ?loc (Psig_type a)
+  let exception_ ?loc a b = mk_item ?loc (Psig_exception (a, b))
+  let module_ ?loc a b = mk_item ?loc (Psig_module (a, b))
+  let rec_module ?loc a = mk_item ?loc (Psig_recmodule a)
+  let modtype ?loc a b = mk_item ?loc (Psig_modtype (a, b))
+  let open_ ?loc a b = mk_item ?loc (Psig_open (a, b))
+  let include_ ?loc a = mk_item ?loc (Psig_include a)
+  let class_ ?loc a = mk_item ?loc (Psig_class a)
+  let class_type ?loc a = mk_item ?loc (Psig_class_type a)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Psig_value (s, vd) ->
+        value ~loc (map_loc sub s) (sub # value_description vd)
+    | Psig_type l ->
+        type_ ~loc
+              (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l)
+    | Psig_exception (s, ed) ->
+        exception_ ~loc (map_loc sub s) (sub # exception_declaration ed)
+    | Psig_module (s, mt) ->
+        module_ ~loc (map_loc sub s) (sub # module_type mt)
+    | Psig_recmodule l ->
+        rec_module ~loc
+                   (List.map (map_tuple (map_loc sub) (sub # module_type)) l)
+    | Psig_modtype (s, Pmodtype_manifest mt) ->
+        modtype ~loc (map_loc sub s) (Pmodtype_manifest  (sub # module_type mt))
+    | Psig_modtype (s, Pmodtype_abstract) ->
+        modtype ~loc (map_loc sub s) Pmodtype_abstract
+    | Psig_open (ovf, s) -> open_ ~loc ovf (map_loc sub s)
+    | Psig_include mt -> include_ ~loc (sub # module_type mt)
+    | Psig_class l -> class_ ~loc (List.map (sub # class_description) l)
+    | Psig_class_type l ->
+        class_type ~loc (List.map (sub # class_type_declaration) l)
+
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let mk ?(loc = Location.none) x = {pmod_desc = x; pmod_loc = loc}
+  let ident ?loc x = mk ?loc (Pmod_ident x)
+  let structure ?loc x = mk ?loc (Pmod_structure x)
+  let functor_ ?loc arg arg_ty body = mk ?loc (Pmod_functor (arg, arg_ty, body))
+  let apply ?loc m1 m2 = mk ?loc (Pmod_apply (m1, m2))
+  let constraint_ ?loc m mty = mk ?loc (Pmod_constraint (m, mty))
+  let unpack ?loc e = mk ?loc (Pmod_unpack e)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pmod_ident x -> ident ~loc (map_loc sub x)
+    | Pmod_structure str -> structure ~loc (sub # structure str)
+    | Pmod_functor (arg, arg_ty, body) -> functor_ ~loc (map_loc sub arg) (sub # module_type arg_ty) (sub # module_expr body)
+    | Pmod_apply (m1, m2) -> apply ~loc (sub # module_expr m1) (sub # module_expr m2)
+    | Pmod_constraint (m, mty) -> constraint_ ~loc (sub # module_expr m) (sub # module_type mty)
+    | Pmod_unpack e -> unpack ~loc (sub # expr e)
+
+  let mk_item ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
+  let eval ?loc a = mk_item ?loc (Pstr_eval a)
+  let value ?loc a b = mk_item ?loc (Pstr_value (a, b))
+  let primitive ?loc a b = mk_item ?loc (Pstr_primitive (a, b))
+  let type_ ?loc a = mk_item ?loc (Pstr_type a)
+  let exception_ ?loc a b = mk_item ?loc (Pstr_exception (a, b))
+  let exn_rebind ?loc a b = mk_item ?loc (Pstr_exn_rebind (a, b))
+  let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b))
+  let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a)
+  let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b))
+  let open_ ?loc a b = mk_item ?loc (Pstr_open (a, b))
+  let class_ ?loc a = mk_item ?loc (Pstr_class a)
+  let class_type ?loc a = mk_item ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk_item ?loc (Pstr_include a)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pstr_eval x -> eval ~loc (sub # expr x)
+    | Pstr_value (r, pel) -> value ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+    | Pstr_primitive (name, vd) -> primitive ~loc (map_loc sub name) (sub # value_description vd)
+    | Pstr_type l -> type_ ~loc (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l)
+    | Pstr_exception (name, ed) -> exception_ ~loc (map_loc sub name) (sub # exception_declaration ed)
+    | Pstr_exn_rebind (s, lid) -> exn_rebind ~loc (map_loc sub s) (map_loc sub lid)
+    | Pstr_module (s, m) -> module_ ~loc (map_loc sub s) (sub # module_expr m)
+    | Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (map_loc sub s, sub # module_type mty, sub # module_expr me)) l)
+    | Pstr_modtype (s, mty) -> modtype ~loc (map_loc sub s) (sub # module_type mty)
+    | Pstr_open (ovf, lid) -> open_ ~loc ovf (map_loc sub lid)
+    | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
+    | Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
+    | Pstr_include e -> include_ ~loc (sub # module_expr e)
+end
+
+module E = struct
+  (* Value expressions for the core language *)
+
+  let mk ?(loc = Location.none) x = {pexp_desc = x; pexp_loc = loc}
+
+  let ident ?loc a = mk ?loc (Pexp_ident a)
+  let constant ?loc a = mk ?loc (Pexp_constant a)
+  let let_ ?loc a b c = mk ?loc (Pexp_let (a, b, c))
+  let function_ ?loc a b c = mk ?loc (Pexp_function (a, b, c))
+  let apply ?loc a b = mk ?loc (Pexp_apply (a, b))
+  let match_ ?loc a b = mk ?loc (Pexp_match (a, b))
+  let try_ ?loc a b = mk ?loc (Pexp_try (a, b))
+  let tuple ?loc a = mk ?loc (Pexp_tuple a)
+  let construct ?loc a b c = mk ?loc (Pexp_construct (a, b, c))
+  let variant ?loc a b = mk ?loc (Pexp_variant (a, b))
+  let record ?loc a b = mk ?loc (Pexp_record (a, b))
+  let field ?loc a b = mk ?loc (Pexp_field (a, b))
+  let setfield ?loc a b c = mk ?loc (Pexp_setfield (a, b, c))
+  let array ?loc a = mk ?loc (Pexp_array a)
+  let ifthenelse ?loc a b c = mk ?loc (Pexp_ifthenelse (a, b, c))
+  let sequence ?loc a b = mk ?loc (Pexp_sequence (a, b))
+  let while_ ?loc a b = mk ?loc (Pexp_while (a, b))
+  let for_ ?loc a b c d e = mk ?loc (Pexp_for (a, b, c, d, e))
+  let constraint_ ?loc a b c = mk ?loc (Pexp_constraint (a, b, c))
+  let when_ ?loc a b = mk ?loc (Pexp_when (a, b))
+  let send ?loc a b = mk ?loc (Pexp_send (a, b))
+  let new_ ?loc a = mk ?loc (Pexp_new a)
+  let setinstvar ?loc a b = mk ?loc (Pexp_setinstvar (a, b))
+  let override ?loc a = mk ?loc (Pexp_override a)
+  let letmodule ?loc (a, b, c)= mk ?loc (Pexp_letmodule (a, b, c))
+  let assert_ ?loc a = mk ?loc (Pexp_assert a)
+  let assertfalse ?loc () = mk ?loc Pexp_assertfalse
+  let lazy_ ?loc a = mk ?loc (Pexp_lazy a)
+  let poly ?loc a b = mk ?loc (Pexp_poly (a, b))
+  let object_ ?loc a = mk ?loc (Pexp_object a)
+  let newtype ?loc a b = mk ?loc (Pexp_newtype (a, b))
+  let pack ?loc a = mk ?loc (Pexp_pack a)
+  let open_ ?loc a b c = mk ?loc (Pexp_open (a, b, c))
+
+  let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc)
+  let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el)
+  let strconst ?loc x = constant ?loc (Const_string x)
+
+  let map sub {pexp_loc = loc; pexp_desc = desc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pexp_ident x -> ident ~loc (map_loc sub x)
+    | Pexp_constant x -> constant ~loc x
+    | Pexp_let (r, pel, e) -> let_ ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
+    | Pexp_function (lab, def, pel) -> function_ ~loc lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+    | Pexp_apply (e, l) -> apply ~loc (sub # expr e) (List.map (map_snd (sub # expr)) l)
+    | Pexp_match (e, l) -> match_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
+    | Pexp_try (e, l) -> try_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
+    | Pexp_tuple el -> tuple ~loc (List.map (sub # expr) el)
+    | Pexp_construct (lid, arg, b) -> construct ~loc (map_loc sub lid) (map_opt (sub # expr) arg) b
+    | Pexp_variant (lab, eo) -> variant ~loc lab (map_opt (sub # expr) eo)
+    | Pexp_record (l, eo) -> record ~loc (List.map (map_tuple (map_loc sub) (sub # expr)) l) (map_opt (sub # expr) eo)
+    | Pexp_field (e, lid) -> field ~loc (sub # expr e) (map_loc sub lid)
+    | Pexp_setfield (e1, lid, e2) -> setfield ~loc (sub # expr e1) (map_loc sub lid) (sub # expr e2)
+    | Pexp_array el -> array ~loc (List.map (sub # expr) el)
+    | Pexp_ifthenelse (e1, e2, e3) -> ifthenelse ~loc (sub # expr e1) (sub # expr e2) (map_opt (sub # expr) e3)
+    | Pexp_sequence (e1, e2) -> sequence ~loc (sub # expr e1) (sub # expr e2)
+    | Pexp_while (e1, e2) -> while_ ~loc (sub # expr e1) (sub # expr e2)
+    | Pexp_for (id, e1, e2, d, e3) -> for_ ~loc (map_loc sub id) (sub # expr e1) (sub # expr e2) d (sub # expr e3)
+    | Pexp_constraint (e, t1, t2) -> constraint_ ~loc (sub # expr e) (map_opt (sub # typ) t1) (map_opt (sub # typ) t2)
+    | Pexp_when (e1, e2) -> when_ ~loc (sub # expr e1) (sub # expr e2)
+    | Pexp_send (e, s) -> send ~loc (sub # expr e) s
+    | Pexp_new lid -> new_ ~loc (map_loc sub lid)
+    | Pexp_setinstvar (s, e) -> setinstvar ~loc (map_loc sub s) (sub # expr e)
+    | Pexp_override sel -> override ~loc (List.map (map_tuple (map_loc sub) (sub # expr)) sel)
+    | Pexp_letmodule (s, me, e) -> letmodule ~loc (map_loc sub s, sub # module_expr me, sub # expr e)
+    | Pexp_assert e -> assert_ ~loc (sub # expr e)
+    | Pexp_assertfalse -> assertfalse ~loc ()
+    | Pexp_lazy e -> lazy_ ~loc (sub # expr e)
+    | Pexp_poly (e, t) -> poly ~loc (sub # expr e) (map_opt (sub # typ) t)
+    | Pexp_object cls -> object_ ~loc (sub # class_structure cls)
+    | Pexp_newtype (s, e) -> newtype ~loc s (sub # expr e)
+    | Pexp_pack me -> pack ~loc (sub # module_expr me)
+    | Pexp_open (ovf, lid, e) -> open_ ~loc ovf (map_loc sub lid) (sub # expr e)
+end
+
+module P = struct
+  (* Patterns *)
+
+  let mk ?(loc = Location.none) x = {ppat_desc = x; ppat_loc = loc}
+  let any ?loc () = mk ?loc Ppat_any
+  let var ?loc a = mk ?loc (Ppat_var a)
+  let alias ?loc a b = mk ?loc (Ppat_alias (a, b))
+  let constant ?loc a = mk ?loc (Ppat_constant a)
+  let tuple ?loc a = mk ?loc (Ppat_tuple a)
+  let construct ?loc a b c = mk ?loc (Ppat_construct (a, b, c))
+  let variant ?loc a b = mk ?loc (Ppat_variant (a, b))
+  let record ?loc a b = mk ?loc (Ppat_record (a, b))
+  let array ?loc a = mk ?loc (Ppat_array a)
+  let or_ ?loc a b = mk ?loc (Ppat_or (a, b))
+  let constraint_ ?loc a b = mk ?loc (Ppat_constraint (a, b))
+  let type_ ?loc a = mk ?loc (Ppat_type a)
+  let lazy_ ?loc a = mk ?loc (Ppat_lazy a)
+  let unpack ?loc a = mk ?loc (Ppat_unpack a)
+
+  let map sub {ppat_desc = desc; ppat_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Ppat_any -> any ~loc ()
+    | Ppat_var s -> var ~loc (map_loc sub s)
+    | Ppat_alias (p, s) -> alias ~loc (sub # pat p) (map_loc sub s)
+    | Ppat_constant c -> constant ~loc c
+    | Ppat_tuple pl -> tuple ~loc (List.map (sub # pat) pl)
+    | Ppat_construct (l, p, b) -> construct ~loc (map_loc sub l) (map_opt (sub # pat) p) b
+    | Ppat_variant (l, p) -> variant ~loc l (map_opt (sub # pat) p)
+    | Ppat_record (lpl, cf) ->
+        record ~loc (List.map (map_tuple (map_loc sub) (sub # pat)) lpl) cf
+    | Ppat_array pl -> array ~loc (List.map (sub # pat) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc (sub # pat p1) (sub # pat p2)
+    | Ppat_constraint (p, t) -> constraint_ ~loc (sub # pat p) (sub # typ t)
+    | Ppat_type s -> type_ ~loc (map_loc sub s)
+    | Ppat_lazy p -> lazy_ ~loc (sub # pat p)
+    | Ppat_unpack s -> unpack ~loc (map_loc sub s)
+end
+
+module CE = struct
+  (* Value expressions for the class language *)
+
+  let mk ?(loc = Location.none) x = {pcl_loc = loc; pcl_desc = x}
+
+  let constr ?loc a b = mk ?loc (Pcl_constr (a, b))
+  let structure ?loc a = mk ?loc (Pcl_structure a)
+  let fun_ ?loc a b c d = mk ?loc (Pcl_fun (a, b, c, d))
+  let apply ?loc a b = mk ?loc (Pcl_apply (a, b))
+  let let_ ?loc a b c = mk ?loc (Pcl_let (a, b, c))
+  let constraint_ ?loc a b = mk ?loc (Pcl_constraint (a, b))
+
+  let map sub {pcl_loc = loc; pcl_desc = desc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pcl_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
+    | Pcl_structure s ->
+        structure ~loc (sub # class_structure s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc lab
+          (map_opt (sub # expr) e)
+          (sub # pat p)
+          (sub # class_expr ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
+    | Pcl_let (r, pel, ce) ->
+        let_ ~loc r
+          (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+          (sub # class_expr ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
+
+
+  let mk_field ?(loc = Location.none) x = {pcf_desc = x; pcf_loc = loc}
+
+  let inher ?loc a b c = mk_field ?loc (Pcf_inher (a, b, c))
+  let valvirt ?loc a b c = mk_field ?loc (Pcf_valvirt (a, b, c))
+  let val_ ?loc a b c d = mk_field ?loc (Pcf_val (a, b, c, d))
+  let virt ?loc a b c = mk_field ?loc (Pcf_virt (a, b, c))
+  let meth ?loc a b c d = mk_field ?loc (Pcf_meth (a, b, c, d))
+  let constr ?loc a b = mk_field ?loc (Pcf_constr (a, b))
+  let init ?loc a = mk_field ?loc (Pcf_init a)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc} =
+    let loc = sub # location loc in
+    match desc with
+    | Pcf_inher (o, ce, s) -> inher ~loc o (sub # class_expr ce) s
+    | Pcf_valvirt (s, m, t) -> valvirt ~loc (map_loc sub s) m (sub # typ t)
+    | Pcf_val (s, m, o, e) -> val_ ~loc (map_loc sub s) m o (sub # expr e)
+    | Pcf_virt (s, p, t) -> virt ~loc (map_loc sub s) p (sub # typ t)
+    | Pcf_meth (s, p, o, e) -> meth ~loc (map_loc sub s) p o (sub # expr e)
+    | Pcf_constr (t1, t2) -> constr ~loc (sub # typ t1) (sub # typ t2)
+    | Pcf_init e -> init ~loc (sub # expr e)
+
+  let map_structure sub {pcstr_pat; pcstr_fields} =
+    {
+     pcstr_pat = sub # pat pcstr_pat;
+     pcstr_fields = List.map (sub # class_field) pcstr_fields;
+    }
+
+  let class_infos sub f {pci_virt; pci_params = (pl, ploc); pci_name; pci_expr; pci_variance; pci_loc} =
+    {
+     pci_virt;
+     pci_params = List.map (map_loc sub) pl, sub # location ploc;
+     pci_name = map_loc sub pci_name;
+     pci_expr = f pci_expr;
+     pci_variance;
+     pci_loc = sub # location pci_loc;
+    }
+end
+
+(* Now, a generic AST mapper class, to be extended to cover all kinds
+   and cases of the OCaml grammar.  The default behavior of the mapper
+   is the identity. *)
+
+class mapper =
+  object(this)
+    method implementation (input_name : string) ast = (input_name, this # structure ast)
+    method interface (input_name: string) ast = (input_name, this # signature ast)
+    method structure l = map_flatten (this # structure_item) l
+    method structure_item si = [ M.map_structure_item this si ]
+    method module_expr = M.map this
+
+    method signature l = map_flatten (this # signature_item) l
+    method signature_item si = [ MT.map_signature_item this si ]
+    method module_type = MT.map this
+    method with_constraint c = MT.map_with_constraint this c
+
+    method class_declaration = CE.class_infos this (this # class_expr)
+    method class_expr = CE.map this
+    method class_field = CE.map_field this
+    method class_structure = CE.map_structure this
+
+    method class_type = CT.map this
+    method class_type_field = CT.map_field this
+    method class_signature = CT.map_signature this
+
+    method class_type_declaration = CE.class_infos this (this # class_type)
+    method class_description = CE.class_infos this (this # class_type)
+
+    method type_declaration = T.map_type_declaration this
+    method type_kind = T.map_type_kind this
+    method typ = T.map this
+
+    method value_description {pval_type; pval_prim; pval_loc} =
+      {
+       pval_type = this # typ pval_type;
+       pval_prim;
+       pval_loc = this # location pval_loc;
+      }
+    method pat = P.map this
+    method expr = E.map this
+
+    method exception_declaration tl = List.map (this # typ) tl
+
+    method location l = l
+  end
+
+class type main_entry_points =
+  object
+    method implementation: string -> structure -> string * structure
+    method interface: string -> signature -> string * signature
+  end
+
+let apply ~source ~target mapper =
+  let ic = open_in_bin source in
+  let magic = String.create (String.length ast_impl_magic_number) in
+  really_input ic magic 0 (String.length magic);
+  if magic <> ast_impl_magic_number && magic <> ast_intf_magic_number then
+    failwith "Bad magic";
+  let input_name = input_value ic in
+  let ast = input_value ic in
+  close_in ic;
+
+  let (input_name, ast) =
+    if magic = ast_impl_magic_number
+    then Obj.magic (mapper # implementation input_name (Obj.magic ast))
+    else Obj.magic (mapper # interface input_name (Obj.magic ast))
+  in
+  let oc = open_out_bin target in
+  output_string oc magic;
+  output_value oc input_name;
+  output_value oc ast;
+  close_out oc
+
+let run_main mapper =
+  try
+    let a = Sys.argv in
+    let n = Array.length a in
+    if n > 2 then
+      apply ~source:a.(n - 2) ~target:a.(n - 1) (mapper (Array.to_list (Array.sub a 1 (n - 3))))
+    else begin
+      Printf.eprintf "Usage: %s [extra_args]  \n%!" Sys.executable_name;
+      exit 1
+    end
+  with exn ->
+    prerr_endline (Printexc.to_string exn);
+    exit 2
+
+let main mapper = run_main (fun _ -> mapper)
+
+let register_function = ref (fun _name f -> run_main f)
+let register name f = !register_function name (f :> string list -> mapper)
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
new file mode 100644
index 00000000..0c3e68ee
--- /dev/null
+++ b/parsing/ast_mapper.mli
@@ -0,0 +1,292 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** Helpers to write Parsetree rewriters *)
+
+open Asttypes
+open Parsetree
+
+(** {2 A generic mapper class} *)
+
+class mapper:
+  object
+    method class_declaration: class_declaration -> class_declaration
+    method class_description: class_description -> class_description
+    method class_expr: class_expr -> class_expr
+    method class_field: class_field -> class_field
+    method class_signature: class_signature -> class_signature
+    method class_structure: class_structure -> class_structure
+    method class_type: class_type -> class_type
+    method class_type_declaration:
+             class_type_declaration -> class_type_declaration
+    method class_type_field: class_type_field -> class_type_field
+    method exception_declaration: exception_declaration -> exception_declaration
+    method expr: expression -> expression
+    method implementation: string -> structure -> string * structure
+    method interface: string -> signature -> string * signature
+    method location: Location.t -> Location.t
+    method module_expr: module_expr -> module_expr
+    method module_type: module_type -> module_type
+    method pat: pattern -> pattern
+    method signature: signature -> signature
+    method signature_item: signature_item -> signature_item list
+    method structure: structure -> structure
+    method structure_item: structure_item -> structure_item list
+    method typ: core_type -> core_type
+    method type_declaration: type_declaration -> type_declaration
+    method type_kind: type_kind -> type_kind
+    method value_description: value_description -> value_description
+    method with_constraint: with_constraint -> with_constraint
+  end
+
+class type main_entry_points =
+  object
+    method implementation: string -> structure -> string * structure
+    method interface: string -> signature -> string * signature
+  end
+
+val apply: source:string -> target:string -> #main_entry_points -> unit
+    (** Apply a mapper to a dumped parsetree found in the [source] file
+        and put the result in the [target] file. *)
+
+val main: #main_entry_points -> unit
+    (** Entry point to call to implement a standalone -ppx rewriter
+        from a mapper object. *)
+
+val run_main: (string list -> #main_entry_points) -> unit
+    (** Same as [main], but with extra arguments from the command line. *)
+
+(** {2 Registration API} *)
+
+val register_function: (string -> (string list -> mapper) -> unit) ref
+
+val register: string -> (string list -> #mapper) -> unit
+
+    (** Apply the [register_function].  The default behavior is to run
+        the mapper immediately, taking arguments from the process
+        command line.  This is to support a scenario where a mapper is
+        linked as a stand-alone executable.
+
+        It is possible to overwrite the [register_function] to define
+        "-ppx drivers", which combine several mappers in a single
+        process.  Typically, a driver starts by defining
+        [register_function] to a custom implementation, then lets ppx
+        rewriters (linked statically or dynamically) register
+        themselves, and then run all or some of them.  It is also
+        possible to have -ppx drivers apply rewriters to only specific
+        parts of an AST.  *)
+
+
+(** {2 Helpers to build Parsetree fragments} *)
+
+module T:
+  sig
+    val mk: ?loc:Location.t -> core_type_desc -> core_type
+    val any: ?loc:Location.t -> unit -> core_type
+    val var: ?loc:Location.t -> string -> core_type
+    val arrow: ?loc:Location.t -> label -> core_type -> core_type -> core_type
+    val tuple: ?loc:Location.t -> core_type list -> core_type
+    val constr:
+          ?loc:Location.t -> Longident.t loc -> core_type list -> core_type
+    val object_: ?loc:Location.t -> core_field_type list -> core_type
+    val class_:
+          ?loc:Location.t -> Longident.t loc -> core_type list ->
+            label list -> core_type
+    val alias: ?loc:Location.t -> core_type -> string -> core_type
+    val variant:
+          ?loc:Location.t -> row_field list -> bool -> label list option ->
+            core_type
+    val poly: ?loc:Location.t -> string list -> core_type -> core_type
+    val package:
+          ?loc:Location.t -> Longident.t loc ->
+            (Longident.t loc * core_type) list -> core_type
+    val field_type: ?loc:Location.t -> core_field_desc -> core_field_type
+    val field: ?loc:Location.t -> string -> core_type -> core_field_type
+    val field_var: ?loc:Location.t -> unit -> core_field_type
+    val core_field_type: mapper -> core_field_type -> core_field_type
+    val row_field: mapper -> row_field -> row_field
+    val map: mapper -> core_type -> core_type
+    val map_type_declaration: mapper -> type_declaration -> type_declaration
+    val map_type_kind: mapper -> type_kind -> type_kind
+  end
+
+module CT:
+  sig
+    val mk: ?loc:Location.t -> class_type_desc -> class_type
+    val constr:
+          ?loc:Location.t -> Longident.t loc -> core_type list -> class_type
+    val signature: ?loc:Location.t -> class_signature -> class_type
+    val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type
+    val map: mapper -> class_type -> class_type
+    val mk_field: ?loc:Location.t -> class_type_field_desc -> class_type_field
+    val inher: ?loc:Location.t -> class_type -> class_type_field
+    val val_:
+          ?loc:Location.t -> string -> mutable_flag -> virtual_flag ->
+            core_type -> class_type_field
+    val virt:
+          ?loc:Location.t -> string -> private_flag -> core_type ->
+            class_type_field
+    val meth:
+          ?loc:Location.t -> string -> private_flag -> core_type ->
+            class_type_field
+    val cstr: ?loc:Location.t -> core_type -> core_type -> class_type_field
+    val map_field: mapper -> class_type_field -> class_type_field
+    val map_signature: mapper -> class_signature -> class_signature
+  end
+
+module MT:
+  sig
+    val mk: ?loc:Location.t -> module_type_desc -> module_type
+    val ident: ?loc:Location.t -> Longident.t loc -> module_type
+    val signature: ?loc:Location.t -> signature -> module_type
+    val functor_:
+          ?loc:Location.t -> string loc -> module_type -> module_type ->
+            module_type
+    val with_:
+          ?loc:Location.t -> module_type ->
+            (Longident.t loc * with_constraint) list -> module_type
+    val typeof_: ?loc:Location.t -> module_expr -> module_type
+    val map: mapper -> module_type -> module_type
+    val map_with_constraint: mapper -> with_constraint -> with_constraint
+    val mk_item: ?loc:Location.t -> signature_item_desc -> signature_item
+    val value:
+          ?loc:Location.t -> string loc -> value_description -> signature_item
+    val type_:
+          ?loc:Location.t -> (string loc * type_declaration) list ->
+            signature_item
+    val exception_:
+          ?loc:Location.t -> string loc -> exception_declaration ->
+            signature_item
+    val module_: ?loc:Location.t -> string loc -> module_type -> signature_item
+    val rec_module:
+          ?loc:Location.t -> (string loc * module_type) list -> signature_item
+    val modtype:
+          ?loc:Location.t -> string loc -> modtype_declaration -> signature_item
+    val open_:
+          ?loc:Location.t -> override_flag -> Longident.t loc -> signature_item
+    val include_: ?loc:Location.t -> module_type -> signature_item
+    val class_: ?loc:Location.t -> class_description list -> signature_item
+    val class_type:
+          ?loc:Location.t -> class_type_declaration list -> signature_item
+    val map_signature_item: mapper -> signature_item -> signature_item
+  end
+
+module M:
+  sig
+    val mk: ?loc:Location.t -> module_expr_desc -> module_expr
+    val ident: ?loc:Location.t -> Longident.t loc -> module_expr
+    val structure: ?loc:Location.t -> structure -> module_expr
+    val functor_: ?loc:Location.t -> string loc -> module_type -> module_expr -> module_expr
+    val apply: ?loc:Location.t -> module_expr -> module_expr -> module_expr
+    val constraint_: ?loc:Location.t -> module_expr -> module_type -> module_expr
+    val unpack: ?loc:Location.t -> expression -> module_expr
+    val map: mapper -> module_expr -> module_expr
+    val mk_item: ?loc:Location.t -> structure_item_desc -> structure_item
+    val eval: ?loc:Location.t -> expression -> structure_item
+    val value: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> structure_item
+    val primitive: ?loc:Location.t -> string loc -> value_description -> structure_item
+    val type_: ?loc:Location.t -> (string loc * type_declaration) list -> structure_item
+    val exception_: ?loc:Location.t -> string loc -> exception_declaration -> structure_item
+    val exn_rebind: ?loc:Location.t -> string loc -> Longident.t loc -> structure_item
+    val module_: ?loc:Location.t -> string loc -> module_expr -> structure_item
+    val rec_module: ?loc:Location.t -> (string loc * module_type * module_expr)      list -> structure_item
+    val modtype: ?loc:Location.t -> string loc -> module_type -> structure_item
+    val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> structure_item
+    val class_: ?loc:Location.t -> class_declaration list -> structure_item
+    val class_type: ?loc:Location.t -> class_type_declaration list -> structure_item
+    val include_: ?loc:Location.t -> module_expr -> structure_item
+    val map_structure_item: mapper -> structure_item -> structure_item
+  end
+
+module E:
+  sig
+    val mk: ?loc:Location.t -> expression_desc -> expression
+    val ident: ?loc:Location.t -> Longident.t loc -> expression
+    val constant: ?loc:Location.t -> constant -> expression
+    val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> expression -> expression
+    val function_: ?loc:Location.t -> label -> expression option -> (pattern * expression) list -> expression
+    val apply: ?loc:Location.t -> expression -> (label * expression) list -> expression
+    val match_: ?loc:Location.t -> expression -> (pattern * expression) list -> expression
+    val try_: ?loc:Location.t -> expression -> (pattern * expression) list -> expression
+    val tuple: ?loc:Location.t -> expression list -> expression
+    val construct: ?loc:Location.t -> Longident.t loc -> expression option -> bool -> expression
+    val variant: ?loc:Location.t -> label -> expression option -> expression
+    val record: ?loc:Location.t -> (Longident.t loc * expression) list -> expression option -> expression
+    val field: ?loc:Location.t -> expression -> Longident.t loc -> expression
+    val setfield: ?loc:Location.t -> expression -> Longident.t loc -> expression -> expression
+    val array: ?loc:Location.t -> expression list -> expression
+    val ifthenelse: ?loc:Location.t -> expression -> expression -> expression option -> expression
+    val sequence: ?loc:Location.t -> expression -> expression -> expression
+    val while_: ?loc:Location.t -> expression -> expression -> expression
+    val for_: ?loc:Location.t -> string loc -> expression -> expression -> direction_flag -> expression -> expression
+    val constraint_: ?loc:Location.t -> expression -> core_type option -> core_type option -> expression
+    val when_: ?loc:Location.t -> expression -> expression -> expression
+    val send: ?loc:Location.t -> expression -> string -> expression
+    val new_: ?loc:Location.t -> Longident.t loc -> expression
+    val setinstvar: ?loc:Location.t -> string loc -> expression -> expression
+    val override: ?loc:Location.t -> (string loc * expression) list -> expression
+    val letmodule: ?loc:Location.t -> string loc * module_expr * expression -> expression
+    val assert_: ?loc:Location.t -> expression -> expression
+    val assertfalse: ?loc:Location.t -> unit -> expression
+    val lazy_: ?loc:Location.t -> expression -> expression
+    val poly: ?loc:Location.t -> expression -> core_type option -> expression
+    val object_: ?loc:Location.t -> class_structure -> expression
+    val newtype: ?loc:Location.t -> string -> expression -> expression
+    val pack: ?loc:Location.t -> module_expr -> expression
+    val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> expression -> expression
+    val lid: ?loc:Location.t -> string -> expression
+    val apply_nolabs: ?loc:Location.t -> expression -> expression list -> expression
+    val strconst: ?loc:Location.t -> string -> expression
+    val map: mapper -> expression -> expression
+  end
+
+module P:
+  sig
+    val mk: ?loc:Location.t -> pattern_desc -> pattern
+    val any: ?loc:Location.t -> unit -> pattern
+    val var: ?loc:Location.t -> string loc -> pattern
+    val alias: ?loc:Location.t -> pattern -> string loc -> pattern
+    val constant: ?loc:Location.t -> constant -> pattern
+    val tuple: ?loc:Location.t -> pattern list -> pattern
+    val construct: ?loc:Location.t -> Longident.t loc -> pattern option -> bool -> pattern
+    val variant: ?loc:Location.t -> label -> pattern option -> pattern
+    val record: ?loc:Location.t -> (Longident.t loc * pattern) list -> closed_flag -> pattern
+    val array: ?loc:Location.t -> pattern list -> pattern
+    val or_: ?loc:Location.t -> pattern -> pattern -> pattern
+    val constraint_: ?loc:Location.t -> pattern -> core_type -> pattern
+    val type_: ?loc:Location.t -> Longident.t loc -> pattern
+    val lazy_: ?loc:Location.t -> pattern -> pattern
+    val unpack: ?loc:Location.t -> string loc -> pattern
+    val map: mapper -> pattern -> pattern
+  end
+
+module CE:
+  sig
+    val mk: ?loc:Location.t -> class_expr_desc -> class_expr
+    val structure: ?loc:Location.t -> class_structure -> class_expr
+    val fun_: ?loc:Location.t -> label -> expression option -> pattern -> class_expr -> class_expr
+    val apply: ?loc:Location.t -> class_expr -> (label * expression) list -> class_expr
+    val let_: ?loc:Location.t -> rec_flag -> (pattern * expression) list -> class_expr -> class_expr
+    val constraint_: ?loc:Location.t -> class_expr -> class_type -> class_expr
+    val map: mapper -> class_expr -> class_expr
+    val mk_field: ?loc:Location.t -> class_field_desc -> class_field
+    val inher: ?loc:Location.t -> override_flag -> class_expr -> string option -> class_field
+    val valvirt: ?loc:Location.t -> string loc -> mutable_flag -> core_type -> class_field
+    val val_: ?loc:Location.t -> string loc -> mutable_flag -> override_flag -> expression -> class_field
+    val virt: ?loc:Location.t -> string loc -> private_flag -> core_type -> class_field
+    val meth: ?loc:Location.t -> string loc -> private_flag -> override_flag -> expression -> class_field
+    val constr: ?loc:Location.t -> core_type -> core_type -> class_field
+    val init: ?loc:Location.t -> expression -> class_field
+    val map_field: mapper -> class_field -> class_field
+    val map_structure: mapper -> class_structure -> class_structure
+    val class_infos: mapper -> ('a -> 'b) -> 'a class_infos -> 'b class_infos
+  end
diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index a5826656..fb6d5ba0 100644
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: asttypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Auxiliary a.s.t. types used by parsetree and typedtree. *)
 
 type constant =
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 5472c8eb..0c98ffc3 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* The lexical analyzer *)
 
 val init : unit -> unit
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 9f2f4b20..ae69b37f 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer.mll 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* The lexer definition *)
 
 {
@@ -174,7 +172,8 @@ let cvt_int32_literal s =
 let cvt_int64_literal s =
   Int64.neg (Int64.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
 let cvt_nativeint_literal s =
-  Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1)))
+  Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0
+                                                       (String.length s - 1)))
 
 (* Remove underscores from float literals *)
 
@@ -189,6 +188,16 @@ let remove_underscores s =
       |  c  -> s.[dst] <- c; remove (src + 1) (dst + 1)
   in remove 0 0
 
+(* recover the name from a LABEL or OPTLABEL token *)
+
+let get_label_name lexbuf =
+  let s = Lexing.lexeme lexbuf in
+  let name = String.sub s 1 (String.length s - 2) in
+  if Hashtbl.mem keyword_table name then
+    raise (Error(Keyword_as_label name, Location.curr lexbuf));
+  name
+;;
+
 (* Update the current location with file name and line number. *)
 
 let update_loc lexbuf file line absolute chars =
@@ -204,6 +213,13 @@ let update_loc lexbuf file line absolute chars =
   }
 ;;
 
+(* 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")
+;;
+
 (* Error report *)
 
 open Format
@@ -222,16 +238,20 @@ let report_error ppf = function
   | Keyword_as_label kwd ->
       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
   | Literal_overflow ty ->
-      fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty
+      fprintf ppf "Integer literal exceeds the range of representable \
+                   integers of type %s" ty
 ;;
 
 }
 
-let newline = ('\010' | '\013' | "\013\010")
+let newline = ('\010' | "\013\010" )
 let blank = [' ' '\009' '\012']
-let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
-let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
-let identchar =
+let lowercase = ['a'-'z' '_']
+let uppercase = ['A'-'Z']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
+let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar_latin1 =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let symbolchar =
   ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
@@ -262,27 +282,25 @@ rule token = parse
   | "~"
       { TILDE }
   | "~" lowercase identchar * ':'
-      { let s = Lexing.lexeme lexbuf in
-        let name = String.sub s 1 (String.length s - 2) in
-        if Hashtbl.mem keyword_table name then
-          raise (Error(Keyword_as_label name, Location.curr lexbuf));
-        LABEL name }
-  | "?"  { QUESTION }
-  | "??" { QUESTIONQUESTION }
+      { LABEL (get_label_name lexbuf) }
+  | "~" lowercase_latin1 identchar_latin1 * ':'
+      { warn_latin1 lexbuf; LABEL (get_label_name lexbuf) }
+  | "?"
+      { QUESTION }
   | "?" lowercase identchar * ':'
-      { let s = Lexing.lexeme lexbuf in
-        let name = String.sub s 1 (String.length s - 2) in
-        if Hashtbl.mem keyword_table name then
-          raise (Error(Keyword_as_label name, Location.curr lexbuf));
-        OPTLABEL name }
+      { OPTLABEL (get_label_name lexbuf) }
+  | "?" lowercase_latin1 identchar_latin1 * ':'
+      { warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) }
   | lowercase identchar *
       { let s = Lexing.lexeme lexbuf in
-          try
-            Hashtbl.find keyword_table s
-          with Not_found ->
-            LIDENT s }
+        try Hashtbl.find keyword_table s
+        with Not_found -> LIDENT s }
+  | lowercase_latin1 identchar_latin1 *
+      { warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) }
   | uppercase identchar *
       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
+  | uppercase_latin1 identchar_latin1 *
+      { warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) }
   | int_literal
       { try
           INT (cvt_int_literal (Lexing.lexeme lexbuf))
@@ -338,7 +356,8 @@ rule token = parse
         let end_loc = comment lexbuf in
         let s = get_stored_string () in
         reset_string_buffer ();
-        COMMENT (s, { start_loc with Location.loc_end = end_loc.Location.loc_end })
+        COMMENT (s, { start_loc with
+                      Location.loc_end = end_loc.Location.loc_end })
       }
   | "(*)"
       { let loc = Location.curr lexbuf  in
diff --git a/parsing/location.ml b/parsing/location.ml
index 947c1a6f..d3f89f44 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: location.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open Lexing
 
 let absname = ref false
@@ -134,32 +132,15 @@ let highlight_dumb ppf lb loc =
   let line = ref 0 in
   let pos_at_bol = ref 0 in
   for pos = 0 to end_pos do
-    let c = lb.lex_buffer.[pos + pos0] in
-    if c <> '\n' then begin
-      if !line = !line_start && !line = !line_end then
-        (* loc is on one line: print whole line *)
-        Format.pp_print_char ppf c
-      else if !line = !line_start then
-        (* first line of multiline loc: print ... before loc_start *)
-        if pos < loc.loc_start.pos_cnum
-        then Format.pp_print_char ppf '.'
-        else Format.pp_print_char ppf c
-      else if !line = !line_end then
-        (* last line of multiline loc: print ... after loc_end *)
-        if pos < loc.loc_end.pos_cnum
-        then Format.pp_print_char ppf c
-        else Format.pp_print_char ppf '.'
-      else if !line > !line_start && !line < !line_end then
-        (* intermediate line of multiline loc: print whole line *)
-        Format.pp_print_char ppf c
-    end else begin
+    match lb.lex_buffer.[pos + pos0] with
+    | '\n' ->
       if !line = !line_start && !line = !line_end then begin
         (* loc is on one line: underline location *)
         Format.fprintf ppf "@.  ";
-        for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
+        for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
           Format.pp_print_char ppf ' '
         done;
-        for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
+        for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
           Format.pp_print_char ppf '^'
         done
       end;
@@ -168,8 +149,29 @@ let highlight_dumb ppf lb loc =
         if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
       end;
       incr line;
-      pos_at_bol := pos + 1;
-    end
+      pos_at_bol := pos + 1
+    | '\r' -> () (* discard *)
+    | c ->
+      if !line = !line_start && !line = !line_end then
+        (* loc is on one line: print whole line *)
+        Format.pp_print_char ppf c
+      else if !line = !line_start then
+        (* first line of multiline loc:
+           print a dot for each char before loc_start *)
+        if pos < loc.loc_start.pos_cnum then
+          Format.pp_print_char ppf '.'
+        else
+          Format.pp_print_char ppf c
+      else if !line = !line_end then
+        (* last line of multiline loc: print a dot for each char
+           after loc_end, even whitespaces *)
+        if pos < loc.loc_end.pos_cnum then
+          Format.pp_print_char ppf c
+        else
+          Format.pp_print_char ppf '.'
+      else if !line > !line_start && !line < !line_end then
+        (* intermediate line of multiline loc: print whole line *)
+        Format.pp_print_char ppf c
   done
 
 (* Highlight the location using one of the supported modes. *)
diff --git a/parsing/location.mli b/parsing/location.mli
index fd247214..bae90902 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: location.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Source code locations (ranges of positions), used in parsetree. *)
 
 open Format
diff --git a/parsing/longident.ml b/parsing/longident.ml
index 3e780be4..706881af 100644
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: longident.ml 11252 2011-10-28 21:21:55Z weis $ *)
-
 type t =
     Lident of string
   | Ldot of t * string
diff --git a/parsing/longident.mli b/parsing/longident.mli
index ba21778d..9e795855 100644
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: longident.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Long identifiers, used in parsetree. *)
 
 type t =
diff --git a/parsing/parse.ml b/parsing/parse.ml
index 3d00603c..aef957d6 100644
--- a/parsing/parse.ml
+++ b/parsing/parse.ml
@@ -10,12 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parse.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Entry points in the parser *)
 
-open Location
-
 (* Skip tokens to the end of the phrase *)
 
 let rec skip_phrase lexbuf =
diff --git a/parsing/parse.mli b/parsing/parse.mli
index d53b63ab..abdde31c 100644
--- a/parsing/parse.mli
+++ b/parsing/parse.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parse.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Entry points in the parser *)
 
 val implementation : Lexing.lexbuf -> Parsetree.structure
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 5cfee41a..429d6bec 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: parser.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
 /* The parser definition */
 
 %{
@@ -46,8 +44,9 @@ let mkcf d =
   { pcf_desc = d; pcf_loc = symbol_rloc () }
 let mkrhs rhs pos = mkloc rhs (rhs_loc pos)
 let mkoption d =
-  { ptyp_desc = Ptyp_constr(mknoloc (Ldot (Lident "*predef*", "option")), [d]);
-    ptyp_loc = d.ptyp_loc}
+  let loc = {d.ptyp_loc with loc_ghost = true} in
+  { ptyp_desc = Ptyp_constr(mkloc (Ldot (Lident "*predef*", "option")) loc,[d]);
+    ptyp_loc = loc}
 
 let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
 let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
@@ -64,7 +63,7 @@ let mkpatvar name pos =
   expressions and patterns that do not appear explicitly in the
   source file they have the loc_ghost flag set to true.
   Then the profiler will not try to instrument them and the
-  -stypes option will not try to display their type.
+  -annot option will not try to display their type.
 
   Every grammar rule that generates an element with a location must
   make at most one non-ghost element, the topmost one.
@@ -79,6 +78,7 @@ let mkpatvar name pos =
 let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
 let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
 let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
+let ghloc d = { txt = d; loc = symbol_gloc () };;
 
 let mkassert e =
   match e with
@@ -122,43 +122,47 @@ let mkuplus name arg =
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
 
-let mkexp_cons args loc =
-  {pexp_desc = Pexp_construct(mkloc (Lident "::") Location.none,
-                              Some args, false); pexp_loc = loc}
+let mkexp_cons consloc args loc =
+  {pexp_desc = Pexp_construct(mkloc (Lident "::") consloc, Some args, false);
+   pexp_loc = loc}
 
-let mkpat_cons args loc =
-  {ppat_desc = Ppat_construct(mkloc (Lident "::") Location.none,
-                              Some args, false); ppat_loc = loc}
+let mkpat_cons consloc args loc =
+  {ppat_desc = Ppat_construct(mkloc (Lident "::") consloc, Some args, false);
+   ppat_loc = loc}
 
-let rec mktailexp = function
+let rec mktailexp nilloc = function
     [] ->
-      ghexp(Pexp_construct(mkloc (Lident "[]") Location.none, None, false))
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      { pexp_desc = Pexp_construct (nil, None, false); pexp_loc = loc }
   | e1 :: el ->
-      let exp_el = mktailexp el in
+      let exp_el = mktailexp nilloc el in
       let l = {loc_start = e1.pexp_loc.loc_start;
                loc_end = exp_el.pexp_loc.loc_end;
                loc_ghost = true}
       in
       let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
-      mkexp_cons arg l
+      mkexp_cons {l with loc_ghost = true} arg l
 
-let rec mktailpat = function
+let rec mktailpat nilloc = function
     [] ->
-      ghpat(Ppat_construct(mkloc (Lident "[]") Location.none, None, false))
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      { ppat_desc = Ppat_construct (nil, None, false); ppat_loc = loc }
   | p1 :: pl ->
-      let pat_pl = mktailpat pl in
+      let pat_pl = mktailpat nilloc pl in
       let l = {loc_start = p1.ppat_loc.loc_start;
                loc_end = pat_pl.ppat_loc.loc_end;
                loc_ghost = true}
       in
       let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
-      mkpat_cons arg l
+      mkpat_cons {l with loc_ghost = true} arg l
 
-let ghstrexp e =
-  { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
+let mkstrexp e =
+  { pstr_desc = Pstr_eval e; pstr_loc = e.pexp_loc }
 
 let array_function str name =
-  mknoloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
+  ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
 
 let rec deep_mkrangepat c1 c2 =
   if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
@@ -177,8 +181,11 @@ let unclosed opening_name opening_num closing_name closing_num =
   raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
                                            rhs_loc closing_num, closing_name)))
 
+let expecting pos nonterm =
+    raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
+
 let bigarray_function str name =
-  mkloc (Ldot(Ldot(Lident "Bigarray", str), name)) Location.none
+  ghloc (Ldot(Ldot(Lident "Bigarray", str), name))
 
 let bigarray_untuplify = function
     { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
@@ -380,7 +387,6 @@ let wrap_type_annotation newtypes core_type body =
 %token  PREFIXOP
 %token PRIVATE
 %token QUESTION
-%token QUESTIONQUESTION
 %token QUOTE
 %token RBRACE
 %token RBRACKET
@@ -493,7 +499,7 @@ interface:
 ;
 toplevel_phrase:
     top_structure SEMISEMI               { Ptop_def $1 }
-  | seq_expr SEMISEMI                    { Ptop_def[ghstrexp $1] }
+  | seq_expr SEMISEMI                    { Ptop_def[mkstrexp $1] }
   | toplevel_directive SEMISEMI          { $1 }
   | EOF                                  { raise End_of_file }
 ;
@@ -503,12 +509,12 @@ top_structure:
 ;
 use_file:
     use_file_tail                        { $1 }
-  | seq_expr use_file_tail               { Ptop_def[ghstrexp $1] :: $2 }
+  | seq_expr use_file_tail               { Ptop_def[mkstrexp $1] :: $2 }
 ;
 use_file_tail:
     EOF                                         { [] }
   | SEMISEMI EOF                                { [] }
-  | SEMISEMI seq_expr use_file_tail             { Ptop_def[ghstrexp $2] :: $3 }
+  | SEMISEMI seq_expr use_file_tail             { Ptop_def[mkstrexp $2] :: $3 }
   | SEMISEMI structure_item use_file_tail       { Ptop_def[$2] :: $3 }
   | SEMISEMI toplevel_directive use_file_tail   { $2 :: $3 }
   | structure_item use_file_tail                { Ptop_def[$1] :: $2 }
@@ -559,12 +565,12 @@ module_expr:
 ;
 structure:
     structure_tail                              { $1 }
-  | seq_expr structure_tail                     { ghstrexp $1 :: $2 }
+  | seq_expr structure_tail                     { mkstrexp $1 :: $2 }
 ;
 structure_tail:
     /* empty */                                 { [] }
   | SEMISEMI                                    { [] }
-  | SEMISEMI seq_expr structure_tail            { ghstrexp $2 :: $3 }
+  | SEMISEMI seq_expr structure_tail            { mkstrexp $2 :: $3 }
   | SEMISEMI structure_item structure_tail      { $2 :: $3 }
   | structure_item structure_tail               { $1 :: $2 }
 ;
@@ -588,8 +594,8 @@ structure_item:
       { mkstr(Pstr_recmodule(List.rev $3)) }
   | MODULE TYPE ident EQUAL module_type
       { mkstr(Pstr_modtype(mkrhs $3 3, $5)) }
-  | OPEN mod_longident
-      { mkstr(Pstr_open (mkrhs $2 2)) }
+  | OPEN override_flag mod_longident
+      { mkstr(Pstr_open ($2, mkrhs $3 3)) }
   | CLASS class_declarations
       { mkstr(Pstr_class (List.rev $2)) }
   | CLASS TYPE class_type_declarations
@@ -658,8 +664,8 @@ signature_item:
       { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_abstract)) }
   | MODULE TYPE ident EQUAL module_type
       { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_manifest $5)) }
-  | OPEN mod_longident
-      { mksig(Psig_open (mkrhs $2 2)) }
+  | OPEN override_flag mod_longident
+      { mksig(Psig_open ($2, mkrhs $3 3)) }
   | INCLUDE module_type
       { mksig(Psig_include $2) }
   | CLASS class_descriptions
@@ -792,7 +798,8 @@ value:
     override_flag mutable_flag label EQUAL seq_expr
       { mkrhs $3 3, $2, $1, $5 }
   | override_flag mutable_flag label type_constraint EQUAL seq_expr
-      { mkrhs $3 3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))) },
+      { let (t, t') = $4 in
+        mkrhs $3 3, $2, $1, ghexp(Pexp_constraint($6, t, t')) }
 ;
 virtual_method:
     METHOD override_flag PRIVATE VIRTUAL label COLON poly_type
@@ -963,8 +970,8 @@ expr:
       { mkexp(Pexp_let($2, List.rev $3, $5)) }
   | LET MODULE UIDENT module_binding IN seq_expr
       { mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) }
-  | LET OPEN mod_longident IN seq_expr
-      { mkexp(Pexp_open(mkrhs $3 3, $5)) }
+  | LET OPEN override_flag mod_longident IN seq_expr
+      { mkexp(Pexp_open($3, mkrhs $4 4, $6)) }
   | FUNCTION opt_bar match_cases
       { mkexp(Pexp_function("", None, List.rev $3)) }
   | FUN labeled_simple_pattern fun_def
@@ -992,9 +999,9 @@ expr:
   | FOR val_ident EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE
       { mkexp(Pexp_for(mkrhs $2 2, $4, $6, $5, $8)) }
   | expr COLONCOLON expr
-      { mkexp_cons (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
+      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
   | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
-      { mkexp_cons (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
+      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
   | expr INFIXOP0 expr
       { mkinfix $1 $2 $3 }
   | expr INFIXOP1 expr
@@ -1072,7 +1079,8 @@ simple_expr:
   | BEGIN seq_expr END
       { reloc_exp $2 }
   | BEGIN END
-      { mkexp (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), None, false)) }
+      { mkexp (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()),
+                               None, false)) }
   | BEGIN seq_expr error
       { unclosed "begin" 1 "end" 3 }
   | LPAREN seq_expr type_constraint RPAREN
@@ -1080,7 +1088,7 @@ simple_expr:
   | simple_expr DOT label_longident
       { mkexp(Pexp_field($1, mkrhs $3 3)) }
   | mod_longident DOT LPAREN seq_expr RPAREN
-      { mkexp(Pexp_open(mkrhs $1 1, $4)) }
+      { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) }
   | mod_longident DOT LPAREN seq_expr error
       { unclosed "(" 3 ")" 5 }
   | simple_expr DOT LPAREN seq_expr RPAREN
@@ -1108,7 +1116,7 @@ simple_expr:
   | LBRACKETBAR BARRBRACKET
       { mkexp(Pexp_array []) }
   | LBRACKET expr_semi_list opt_semi RBRACKET
-      { reloc_exp (mktailexp (List.rev $2)) }
+      { reloc_exp (mktailexp (rhs_loc 4) (List.rev $2)) }
   | LBRACKET expr_semi_list opt_semi error
       { unclosed "[" 1 "]" 4 }
   | PREFIXOP simple_expr
@@ -1171,7 +1179,9 @@ let_binding:
     val_ident fun_binding
       { (mkpatvar $1 1, $2) }
   | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
-      { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
+      { (ghpat(Ppat_constraint(mkpatvar $1 1,
+                               ghtyp(Ptyp_poly(List.rev $3,$5)))),
+         $7) }
   | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
       { let exp, poly = wrap_type_annotation $4 $6 $8 in
         (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
@@ -1205,7 +1215,7 @@ fun_def:
 ;
 match_action:
     MINUSGREATER seq_expr                       { $2 }
-  | WHEN seq_expr MINUSGREATER seq_expr         { mkexp(Pexp_when($2, $4)) }
+  | WHEN seq_expr MINUSGREATER seq_expr         { ghexp(Pexp_when($2, $4)) }
 ;
 expr_comma_list:
     expr_comma_list COMMA expr                  { $3 :: $1 }
@@ -1251,6 +1261,8 @@ pattern:
       { $1 }
   | pattern AS val_ident
       { mkpat(Ppat_alias($1, mkrhs $3 3)) }
+  | pattern AS error
+      { expecting 3 "identifier" }
   | pattern_comma_list  %prec below_COMMA
       { mkpat(Ppat_tuple(List.rev $1)) }
   | constr_longident pattern %prec prec_constr_appl
@@ -1258,11 +1270,17 @@ pattern:
   | name_tag pattern %prec prec_constr_appl
       { mkpat(Ppat_variant($1, Some $2)) }
   | pattern COLONCOLON pattern
-      { mkpat_cons (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) },
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+  | pattern COLONCOLON error
+      { expecting 3 "pattern" }
   | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
-      { mkpat_cons (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
+      { unclosed "(" 4 ")" 8 }
   | pattern BAR pattern
       { mkpat(Ppat_or($1, $3)) }
+  | pattern BAR error
+      { expecting 3 "pattern" }
   | LAZY simple_pattern
       { mkpat(Ppat_lazy $2) }
 ;
@@ -1284,9 +1302,9 @@ simple_pattern:
   | LBRACE lbl_pattern_list RBRACE
       { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
   | LBRACE lbl_pattern_list error
-      { unclosed "{" 1 "}" 4 }
+      { unclosed "{" 1 "}" 3 }
   | LBRACKET pattern_semi_list opt_semi RBRACKET
-      { reloc_pat (mktailpat (List.rev $2)) }
+      { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
   | LBRACKET pattern_semi_list opt_semi error
       { unclosed "[" 1 "]" 4 }
   | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
@@ -1303,10 +1321,13 @@ simple_pattern:
       { mkpat(Ppat_constraint($2, $4)) }
   | LPAREN pattern COLON core_type error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN pattern COLON error
+      { expecting 4 "type" }
   | LPAREN MODULE UIDENT RPAREN
       { mkpat(Ppat_unpack (mkrhs $3 3)) }
   | LPAREN MODULE UIDENT COLON package_type RPAREN
-      { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),ghtyp(Ptyp_package $5))) }
+      { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)),
+                              ghtyp(Ptyp_package $5))) }
   | LPAREN MODULE UIDENT COLON package_type error
       { unclosed "(" 1 ")" 6 }
 ;
@@ -1314,16 +1335,18 @@ simple_pattern:
 pattern_comma_list:
     pattern_comma_list COMMA pattern            { $3 :: $1 }
   | pattern COMMA pattern                       { [$3; $1] }
+  | pattern COMMA error                         { expecting 3 "pattern" }
 ;
 pattern_semi_list:
     pattern                                     { [$1] }
   | pattern_semi_list SEMI pattern              { $3 :: $1 }
 ;
 lbl_pattern_list:
-     lbl_pattern { [$1], Closed }
-  |  lbl_pattern SEMI { [$1], Closed }
-  |  lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open }
-  |  lbl_pattern SEMI lbl_pattern_list { let (fields, closed) = $3 in $1 :: fields, closed }
+    lbl_pattern { [$1], Closed }
+  | lbl_pattern SEMI { [$1], Closed }
+  | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open }
+  | lbl_pattern SEMI lbl_pattern_list
+      { let (fields, closed) = $3 in $1 :: fields, closed }
 ;
 lbl_pattern:
     label_longident EQUAL pattern
@@ -1446,7 +1469,8 @@ label_declarations:
   | label_declarations SEMI label_declaration   { $3 :: $1 }
 ;
 label_declaration:
-    mutable_flag label COLON poly_type          { (mkrhs $2 2, $1, $4, symbol_rloc()) }
+    mutable_flag label COLON poly_type
+      { (mkrhs $2 2, $1, $4, symbol_rloc()) }
 ;
 
 /* "with" constraints (additional type equations over signature components) */
@@ -1458,28 +1482,30 @@ with_constraints:
 with_constraint:
     TYPE type_parameters label_longident with_type_binder core_type constraints
       { let params, variance = List.split $2 in
-        (mkrhs $3 3,  Pwith_type {ptype_params = List.map (fun x -> Some x) params;
-                         ptype_cstrs = List.rev $6;
-                         ptype_kind = Ptype_abstract;
-                         ptype_manifest = Some $5;
-                         ptype_private = $4;
-                         ptype_variance = variance;
-                         ptype_loc = symbol_rloc()}) }
+        (mkrhs $3 3,
+         Pwith_type {ptype_params = List.map (fun x -> Some x) params;
+                     ptype_cstrs = List.rev $6;
+                     ptype_kind = Ptype_abstract;
+                     ptype_manifest = Some $5;
+                     ptype_private = $4;
+                     ptype_variance = variance;
+                     ptype_loc = symbol_rloc()}) }
     /* used label_longident instead of type_longident to disallow
        functor applications in type path */
-  | TYPE type_parameters label_longident COLONEQUAL core_type
+  | TYPE type_parameters label COLONEQUAL core_type
       { let params, variance = List.split $2 in
-        (mkrhs $3 3, Pwith_typesubst {ptype_params = List.map (fun x -> Some x) params;
-                              ptype_cstrs = [];
-                              ptype_kind = Ptype_abstract;
-                              ptype_manifest = Some $5;
-                              ptype_private = Public;
-                              ptype_variance = variance;
-                              ptype_loc = symbol_rloc()}) }
+        (mkrhs (Lident $3) 3,
+         Pwith_typesubst { ptype_params = List.map (fun x -> Some x) params;
+                           ptype_cstrs = [];
+                           ptype_kind = Ptype_abstract;
+                           ptype_manifest = Some $5;
+                           ptype_private = Public;
+                           ptype_variance = variance;
+                           ptype_loc = symbol_rloc()}) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
-  | MODULE mod_longident COLONEQUAL mod_ext_longident
-      { (mkrhs $2 2, Pwith_modsubst (mkrhs $4 4)) }
+  | MODULE UIDENT COLONEQUAL mod_ext_longident
+      { (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
 ;
 with_type_binder:
     EQUAL          { Public }
@@ -1550,7 +1576,7 @@ simple_core_type2:
   | LBRACKET tag_field RBRACKET
       { mktyp(Ptyp_variant([$2], true, None)) }
 /* PR#3835: this is not LR(1), would need lookahead=2
-  | LBRACKET simple_core_type2 RBRACKET
+  | LBRACKET simple_core_type RBRACKET
       { mktyp(Ptyp_variant([$2], true, None)) }
 */
   | LBRACKET BAR row_field_list RBRACKET
@@ -1585,7 +1611,7 @@ row_field_list:
 ;
 row_field:
     tag_field                                   { $1 }
-  | simple_core_type2                           { Rinherit $1 }
+  | simple_core_type                            { Rinherit $1 }
 ;
 tag_field:
     name_tag OF opt_ampersand amper_type_list
@@ -1646,17 +1672,17 @@ constant:
   | NATIVEINT                                   { Const_nativeint $1 }
 ;
 signed_constant:
-    constant                                    { $1 }
-  | MINUS INT                                   { Const_int(- $2) }
-  | MINUS FLOAT                                 { Const_float("-" ^ $2) }
-  | MINUS INT32                                 { Const_int32(Int32.neg $2) }
-  | MINUS INT64                                 { Const_int64(Int64.neg $2) }
-  | MINUS NATIVEINT                             { Const_nativeint(Nativeint.neg $2) }
-  | PLUS INT                                    { Const_int $2 }
-  | PLUS FLOAT                                  { Const_float $2 }
-  | PLUS INT32                                  { Const_int32 $2 }
-  | PLUS INT64                                  { Const_int64 $2 }
-  | PLUS NATIVEINT                              { Const_nativeint $2 }
+    constant                               { $1 }
+  | MINUS INT                              { Const_int(- $2) }
+  | MINUS FLOAT                            { Const_float("-" ^ $2) }
+  | MINUS INT32                            { Const_int32(Int32.neg $2) }
+  | MINUS INT64                            { Const_int64(Int64.neg $2) }
+  | MINUS NATIVEINT                        { Const_nativeint(Nativeint.neg $2) }
+  | PLUS INT                               { Const_int $2 }
+  | PLUS FLOAT                             { Const_float $2 }
+  | PLUS INT32                             { Const_int32 $2 }
+  | PLUS INT64                             { Const_int64 $2 }
+  | PLUS NATIVEINT                         { Const_nativeint $2 }
 ;
 
 /* Identifiers and long identifiers */
@@ -1668,6 +1694,9 @@ ident:
 val_ident:
     LIDENT                                      { $1 }
   | LPAREN operator RPAREN                      { $2 }
+  | LPAREN operator error                       { unclosed "(" 1 ")" 3 }
+  | LPAREN error                                { expecting 2 "operator" }
+  | LPAREN MODULE error                         { expecting 3 "module-expr" }
 ;
 operator:
     PREFIXOP                                    { $1 }
@@ -1749,6 +1778,7 @@ any_longident:
   | LPAREN RPAREN                               { Lident "()" }
   | FALSE                                       { Lident "false" }
   | TRUE                                        { Lident "true" }
+;
 
 /* Toplevel directives */
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 5d7765c9..ce6ac362 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsetree.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Abstract syntax tree produced by parsing *)
 
 open Asttypes
@@ -104,7 +102,8 @@ and expression_desc =
   | Pexp_ifthenelse of expression * expression * expression option
   | Pexp_sequence of expression * expression
   | Pexp_while of expression * expression
-  | Pexp_for of string loc *  expression * expression * direction_flag * expression
+  | Pexp_for of
+      string loc *  expression * expression * direction_flag * expression
   | Pexp_constraint of expression * core_type option * core_type option
   | Pexp_when of expression * expression
   | Pexp_send of expression * string
@@ -119,14 +118,14 @@ and expression_desc =
   | Pexp_object of class_structure
   | Pexp_newtype of string * expression
   | Pexp_pack of module_expr
-  | Pexp_open of Longident.t loc * expression
+  | Pexp_open of override_flag * Longident.t loc * expression
 
 (* Value descriptions *)
 
 and value_description =
   { pval_type: core_type;
     pval_prim: string list;
-    pval_loc : Location.t
+    pval_loc: Location.t
     }
 
 (* Type declarations *)
@@ -161,14 +160,14 @@ and class_type_desc =
   | Pcty_fun of label * core_type * class_type
 
 and class_signature = {
-    pcsig_self : core_type;
-    pcsig_fields : class_type_field list;
-    pcsig_loc : Location.t;
+    pcsig_self: core_type;
+    pcsig_fields: class_type_field list;
+    pcsig_loc: Location.t;
   }
 
 and class_type_field = {
-    pctf_desc : class_type_field_desc;
-    pctf_loc : Location.t;
+    pctf_desc: class_type_field_desc;
+    pctf_loc: Location.t;
   }
 
 and class_type_field_desc =
@@ -197,23 +196,23 @@ and class_expr_desc =
   | Pcl_constraint of class_expr * class_type
 
 and class_structure = {
-    pcstr_pat : pattern;
-    pcstr_fields :  class_field list;
+    pcstr_pat: pattern;
+    pcstr_fields: class_field list;
   }
 
 and class_field = {
-    pcf_desc : class_field_desc;
-    pcf_loc : Location.t;
+    pcf_desc: class_field_desc;
+    pcf_loc: Location.t;
   }
 
 and class_field_desc =
     Pcf_inher of override_flag * class_expr * string option
   | Pcf_valvirt of (string loc * mutable_flag * core_type)
   | Pcf_val of (string loc * mutable_flag * override_flag * expression)
-  | Pcf_virt  of (string loc * private_flag * core_type)
-  | Pcf_meth of (string loc * private_flag *override_flag * expression)
-  | Pcf_constr  of (core_type * core_type)
-  | Pcf_init  of expression
+  | Pcf_virt of (string loc * private_flag * core_type)
+  | Pcf_meth of (string loc * private_flag * override_flag * expression)
+  | Pcf_constr of (core_type * core_type)
+  | Pcf_init of expression
 
 and class_declaration = class_expr class_infos
 
@@ -243,7 +242,7 @@ and signature_item_desc =
   | Psig_module of string loc * module_type
   | Psig_recmodule of (string loc * module_type) list
   | Psig_modtype of string loc * modtype_declaration
-  | Psig_open of Longident.t loc
+  | Psig_open of override_flag * Longident.t loc
   | Psig_include of module_type
   | Psig_class of class_description list
   | Psig_class_type of class_type_declaration list
@@ -288,7 +287,7 @@ and structure_item_desc =
   | Pstr_module of string loc * module_expr
   | Pstr_recmodule of (string loc * module_type * module_expr) list
   | Pstr_modtype of string loc * module_type
-  | Pstr_open of Longident.t loc
+  | Pstr_open of override_flag * Longident.t loc
   | Pstr_class of class_declaration list
   | Pstr_class_type of class_type_declaration list
   | Pstr_include of module_expr
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
new file mode 100644
index 00000000..0965ca6a
--- /dev/null
+++ b/parsing/pprintast.ml
@@ -0,0 +1,1246 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*    Hongbo Zhang (University of Pennsylvania)                           *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*   en Automatique.  All rights reserved.  This file is distributed      *)
+(*   under the terms of the Q Public License version 1.0.                 *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *)
+(* Printing code expressions *)
+(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
+(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
+(* TODO more fine-grained precedence pretty-printing *)
+
+open Asttypes
+open Format
+open Location
+open Longident
+open Parsetree
+
+let prefix_symbols  = [ '!'; '?'; '~' ] ;;
+let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
+                      '$'; '%' ]
+let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/';
+                       ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ]
+let numeric_chars  = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ]
+
+(* type fixity = Infix| Prefix  *)
+
+
+let special_infix_strings =
+  ["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
+   may have resulted from Pexp -> Texp -> Pexp translation, then checking
+   if all the characters in the beginning of the string are valid infix
+   characters. *)
+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
+  | _ -> `Normal
+
+let view_fixity_of_exp = function
+  | {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
+  | _ -> `Normal  ;;
+
+let is_infix  = function  | `Infix _ -> true | _  -> false
+
+let is_predef_option = function
+  | (Ldot (Lident "*predef*","option")) -> true
+  | _ -> false
+
+type space_formatter = (unit, Format.formatter, unit) format
+
+let override = function
+  | Override -> "!"
+  | Fresh -> ""
+
+(* variance encoding: need to sync up with the [parser.mly] *)
+let type_variance = function
+  | (false,false) -> ""
+  | (true,false) -> "+"
+  | (false,true) -> "-"
+  | (_,_) -> assert false
+
+type construct =
+  [ `cons of expression list
+  | `list of expression list
+  | `nil
+  | `normal
+  | `simple of Longident.t
+  | `tuple ]
+
+let view_expr x =
+  match x.pexp_desc with
+  | Pexp_construct ( {txt= Lident "()"; _},_,_) -> `tuple
+  | Pexp_construct ( {txt= Lident "[]";_},_,_) -> `nil
+  | Pexp_construct ( {txt= Lident"::";_},Some _,_) ->
+      let rec loop exp acc = match exp with
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_,_);_} ->
+              (List.rev acc,true)
+          | {pexp_desc=
+             Pexp_construct ({txt=Lident "::";_},
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);_}),_);_} ->
+              loop e2 (e1::acc)
+          | e -> (List.rev (e::acc),false) in
+      let (ls,b) = loop x []  in
+      if b then
+        `list ls
+      else `cons ls
+  | Pexp_construct (x,None,_) -> `simple (x.txt)
+  | _ -> `normal
+
+let is_simple_construct :construct -> bool = function
+  | `nil | `tuple | `list _ | `simple _  -> true
+  | `cons _ | `normal -> false
+
+let pp = fprintf
+
+let rec is_irrefut_patt x =
+  match x.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_unpack _ -> true
+  | Ppat_alias (p,_) -> is_irrefut_patt p
+  | Ppat_tuple (ps) -> List.for_all is_irrefut_patt ps
+  | Ppat_constraint (p,_) -> is_irrefut_patt p
+  | Ppat_or (l,r) -> is_irrefut_patt l || is_irrefut_patt r
+  | Ppat_record (ls,_) -> List.for_all (fun (_,x) -> is_irrefut_patt x) ls
+  | Ppat_lazy p -> is_irrefut_patt p
+  | Ppat_constant _ | Ppat_construct _  | Ppat_variant _ | Ppat_array _
+    | Ppat_type _ -> false (*conservative*)
+class printer  ()= object(self:'self)
+  val pipe = false
+  val semi = false
+  val ifthenelse = false
+  method under_pipe = {}
+  method under_semi = {}
+  method under_ifthenelse = {}
+  method reset_semi = {}
+  method reset_ifthenelse = {}
+  method reset_pipe = {}
+  method reset = {}
+  method list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+    ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+    Format.formatter -> 'a list -> unit
+        = fun  ?sep ?first  ?last fu f xs ->
+          let first = match first with Some x -> x |None -> ""
+          and last = match last with Some x -> x |None -> ""
+          and sep = match sep with Some x -> x |None -> "@ " in
+          let aux f = function
+            | [] -> ()
+            | [x] -> fu f x
+            | xs ->
+                let rec loop  f = function
+                  | [x] -> fu f x
+                  | x::xs ->  pp f "%a%(%)%a" fu x sep loop xs
+                  | _ -> assert false in begin
+                      pp f "%(%)%a%(%)" first loop xs last;
+                  end in
+          aux f xs
+  method option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit =
+      fun  ?first  ?last fu f a ->
+        let first = match first with Some x -> x | None -> ""
+        and last = match last with Some x -> x | None -> "" in
+        match a with
+        | None -> ()
+        | Some x -> pp f "%(%)%a%(%)" first fu x last
+  method paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+    bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
+    fun  ?(first="") ?(last="") b fu f x ->
+      if b then pp f "(%(%)%a%(%))" first fu  x last
+      else fu f x
+
+
+  method longident f = function
+    | Lident s ->
+        (match s.[0] with
+        | 'a' .. 'z' | 'A' .. 'Z' | '_'
+          when not (is_infix (fixity_of_string s)) ->
+            pp f "%s" s
+        | _ -> pp f "(@;%s@;)" s )
+    | Ldot(y,s) -> (match s.[0] with
+      | 'a'..'z' | 'A' .. 'Z' | '_' when not(is_infix (fixity_of_string s)) ->
+          pp f "%a.%s" self#longident y s
+      | _ ->
+          pp f "%a.(@;%s@;)@ " self#longident y s)
+    | Lapply (y,s) ->
+        pp f "%a(%a)" self#longident y self#longident s
+  method longident_loc f x = pp f "%a" self#longident x.txt
+  method constant f  = function
+    | Const_char i -> pp f "%C"  i
+    | Const_string i -> pp f "%S" i
+    | Const_int i -> self#paren (i<0) (fun f -> pp f "%d") f i
+    | Const_float  i -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
+    | Const_int32 i -> self#paren (i<0l) (fun f -> pp f "%ldl") f i
+    | Const_int64 i -> self#paren (i<0L) (fun f -> pp f "%LdL") f i
+                                         (* pp f "%LdL" i *)
+    | Const_nativeint i -> self#paren (i<0n) (fun f -> pp f "%ndn") f i
+                                             (* pp f "%ndn" i *)
+
+  (* trailing space*)
+  method mutable_flag f   = function
+    | Immutable -> ()
+    | Mutable -> pp f "mutable@;"
+  method virtual_flag f  = function
+    | Concrete -> ()
+    | Virtual -> pp f "virtual@;"
+
+  (* trailing space added *)
+  method rec_flag f = function
+    | Nonrecursive -> ()
+    | Recursive | Default -> pp f "rec "
+  method direction_flag f = function
+    | Upto -> pp f "to@ "
+    | Downto -> pp f "downto@ "
+  method private_flag f = function
+    | Public -> ()
+    | Private -> pp f "private@ "
+
+  method constant_string f s = pp f "%S" s
+  method tyvar f str = pp f "'%s" str
+  method string_quot f x = pp f "`%s" x
+  method type_var_option f str =
+    match str with
+    | None -> pp f "_" (* wildcard*)
+    | Some {txt;_} -> self#tyvar f txt
+
+          (* c ['a,'b] *)
+  method class_params_def f =  function
+    | [] -> ()
+    | l ->
+        pp f "[%a] " (* space *)
+          (self#list (fun f ({txt;_},s) ->
+            pp f "%s%a" (type_variance s) self#tyvar txt) ~sep:",") l
+
+  method type_with_label f (label,({ptyp_desc;_}as c) ) =
+    match label with
+    | "" ->  self#core_type1 f c (* otherwise parenthesize *)
+    | s  ->
+        if s.[0]='?' then
+          match ptyp_desc with
+          | Ptyp_constr ({txt;_}, l) ->
+              assert (is_predef_option txt);
+              pp f "%s:%a" s (self#list self#core_type1) l
+          | _ -> failwith "invalid input in print_type_with_label"
+        else pp f "%s:%a" s self#core_type1 c
+  method core_type f x =
+    match x.ptyp_desc with
+    | Ptyp_arrow (l, ct1, ct2) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          self#type_with_label (l,ct1) self#core_type ct2
+    | Ptyp_alias (ct, s) ->
+        pp f "@[<2>%a@;as@;'%s@]" self#core_type1 ct s
+    | Ptyp_poly (sl, ct) ->
+        pp f "@[<2>%a%a@]"
+          (fun f l ->
+            pp f "%a"
+              (fun f l -> match l with
+              | [] -> ()
+              | _ ->
+                  pp f "%a@;.@;"
+                    (self#list self#tyvar ~sep:"@;")  l)
+              l)
+          sl  self#core_type ct
+    | _ -> pp f "@[<2>%a@]" self#core_type1 x
+  method core_type1 f x =
+    match x.ptyp_desc with
+    | Ptyp_any -> pp f "_";
+    | Ptyp_var s -> self#tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (self#list self#core_type1 ~sep:"*@;") l
+    | Ptyp_constr (li, l) ->
+        pp f (* "%a%a@;" *) "%a%a"
+          (fun f l -> match l with
+          |[] -> ()
+          |[x]-> pp f "%a@;" self#core_type1  x
+          | _ -> self#list ~first:"(" ~last:")@;" self#core_type ~sep:"," f l)
+          l self#longident_loc li
+    | Ptyp_variant (l, closed, low) ->
+        let type_variant_helper f x =
+          match x with
+          | Rtag (l, _, ctl) -> pp f "@[<2>%a%a@]"  self#string_quot l
+                (fun f l -> match l with
+                |[] -> ()
+                | _ -> pp f "@;of@;%a"
+                      (self#list self#core_type ~sep:"&")  ctl) ctl
+          | Rinherit ct -> self#core_type f ct in
+        pp f "@[<2>[%a%a]@]"
+          (fun f l
+            ->
+              match l with
+              | [] -> ()
+              | _ ->
+              pp f "%s@;%a"
+                (match (closed,low) with
+                | (true,None) -> ""
+                | (true,Some _) -> "<" (* FIXME desugar the syntax sugar *)
+                | (false,_) -> ">")
+                (self#list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low
+            ->
+              match low with
+              |Some [] |None -> ()
+              |Some xs ->
+              pp f ">@ %a"
+                (self#list self#string_quot) xs) low
+    | Ptyp_object l ->
+        let  core_field_type f {pfield_desc;_} =
+          match pfield_desc with
+          | Pfield (s, ct) ->
+              pp f "@[%s@ :%a@ @]" s self#core_type ct
+          | Pfield_var -> pp f ".." in
+        pp f "@[<@ %a@ >@]" (self#list core_field_type ~sep:";") l
+    | Ptyp_class (li, l, low) ->   (*FIXME*)
+        pp f "@[%a#%a%a@]"
+          (self#list self#core_type ~sep:"," ~first:"(" ~last:")") l
+          self#longident_loc li
+          (fun f low -> match low with
+          | [] -> ()
+          | _ -> pp f "@ [>@ %a]" (self#list self#string_quot) low) low
+    | Ptyp_package (lid, cstrs) ->
+        let aux f (s, ct) =
+          pp f "type %a@ =@ %a" self#longident_loc s self#core_type ct  in
+        (match cstrs with
+        |[] -> pp f "@[(module@ %a)@]" self#longident_loc lid
+        |_ ->
+            pp f "@[(module@ %a@ with@ %a)@]" self#longident_loc lid
+              (self#list aux  ~sep:"@ and@ ")  cstrs)
+    | _ -> self#paren true self#core_type f x
+          (********************pattern********************)
+          (* be cautious when use [pattern], [pattern1] is preferred *)
+  method pattern f x =
+    let rec pattern_or_helper  cur = function
+      |{ppat_desc = Ppat_constant (Const_char a);_}
+        ->
+          if Char.code a = Char.code cur + 1 then
+            Some a
+          else None
+      |{ppat_desc =
+        Ppat_or({ppat_desc=Ppat_constant (Const_char a);_}, p2);_} ->
+          if Char.code a = Char.code cur + 1 then
+            pattern_or_helper a p2
+          else None
+      | _ -> None in
+    let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+      | {ppat_desc= Ppat_or (p1,p2);_} ->
+          list_of_pattern  (p2::acc) p1
+      | x -> x::acc in
+    match x.ppat_desc with
+    | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]"
+          self#pattern p
+          (fun f s->
+            if is_infix (fixity_of_string s.txt)
+               || List.mem s.txt.[0] prefix_symbols
+            then pp f "( %s )" s.txt
+            else pp f "%s" s.txt ) s (* RA*)
+    | Ppat_or (p1, p2) -> (* *)
+        (match p1 with
+        | {ppat_desc=Ppat_constant (Const_char a);_} ->
+            (match pattern_or_helper a p2 with
+            |Some b -> pp f "@[<2>%C..%C@]" a b
+            |None ->
+                pp f "@[%a@]" (self#list ~sep:"@,|" self#pattern)
+                   (list_of_pattern [] x))
+        | _ ->
+            pp f "@[%a@]" (self#list ~sep:"@,|" self#pattern)
+               (list_of_pattern [] x)
+        )
+    | _ -> self#pattern1 f x
+  method pattern1 (f:Format.formatter) (x:pattern) :unit =
+    let rec pattern_list_helper f  =  function
+      | {ppat_desc =
+         Ppat_construct
+           ({ txt = Lident("::") ;_},
+            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}),
+            _);_} ->
+              pp f "%a::%a"  self#simple_pattern  pat1  pattern_list_helper pat2 (*RA*)
+      | p -> self#pattern1 f p in
+    match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->  pp f "@[<2>`%s@;%a@]" l self#pattern1 p (*RA*)
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _, _) -> self#simple_pattern f x
+    | Ppat_construct (({txt;_} as li), po, _) -> (* FIXME The third field always false *)
+        if txt = Lident "::" then
+          pp f "%a" pattern_list_helper x
+        else
+          (match po with
+          |Some x ->
+              pp f "%a@;%a"  self#longident_loc li self#simple_pattern x
+          | None -> pp f "%a@;"self#longident_loc li )
+    | _ -> self#simple_pattern f x
+  method simple_pattern (f:Format.formatter) (x:pattern) :unit =
+    match x.ppat_desc with
+    | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _, _) -> pp f  "%s" x
+    | Ppat_any -> pp f "_";
+    | Ppat_var ({txt = txt;_}) ->
+        if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then
+          if txt.[0]='*' || txt.[String.length txt - 1] = '*' then
+            pp f "(@;%s@;)@ " txt
+          else
+            pp f "(%s)" txt
+        else
+          pp f "%s" txt
+    | Ppat_array l ->
+        pp f "@[<2>[|%a|]@]"  (self#list self#pattern1 ~sep:";") l
+    | Ppat_unpack (s) ->
+        pp f "(module@ %s)@ " s.txt
+    | Ppat_type li ->
+        pp f "#%a" self#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 ->
+              pp f "@[<2>%a@]"  self#longident_loc li
+          | _ ->
+            pp f "@[<2>%a@;=@;%a@]" self#longident_loc li self#pattern1 p in
+        (match closed with
+        |Closed ->
+            pp f "@[<2>{@;%a@;}@]"
+              (self#list longident_x_pattern ~sep:";@;") l
+        | _ ->
+            pp f "@[<2>{@;%a;_}@]"
+              (self#list longident_x_pattern ~sep:";@;") l)
+    | Ppat_tuple l -> pp f "@[<1>(%a)@]" (self#list  ~sep:"," self#pattern1)  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" self#constant c
+    | Ppat_variant (l,None) ->  pp f "`%s" l
+    | Ppat_constraint (p, ct) ->
+        pp f "@[<2>(%a@;:@;%a)@]" self#pattern1 p self#core_type ct
+    | Ppat_lazy p ->
+        pp f "@[<2>(lazy@;%a)@]" self#pattern1 p
+    | _ -> self#paren true self#pattern f x
+
+  method label_exp f (l,opt,p) =
+    if l = "" then
+      pp f "%a@ " self#simple_pattern p (*single case pattern parens needed here *)
+    else
+      if l.[0] = '?' then
+        let len = String.length l - 1 in
+        let rest = String.sub l 1 len in begin
+          match p.ppat_desc with
+          | Ppat_var {txt;_} when txt = rest ->
+              (match opt with
+              |Some o -> pp f "?(%s=@;%a)@;" rest  self#expression o
+              | None -> pp f "?%s@ " rest)
+          | _ -> (match opt with
+            | Some o -> pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o
+            | None -> pp f "%s:%a@;" l self#simple_pattern p  )
+        end
+      else
+        (match p.ppat_desc with
+        | Ppat_var {txt;_} when txt = l ->
+            pp f "~%s@;" l
+        | _ ->  pp f "~%s:%a@;" l self#simple_pattern p )
+  method sugar_expr f e =
+    match e.pexp_desc with
+    | Pexp_apply
+        ({pexp_desc=
+          Pexp_ident
+            {txt= Ldot (Lident (("Array"|"String") as s),"get");_};_},
+         [(_,e1);(_,e2)]) -> begin
+              let fmt:(_,_,_)format =
+                if s= "Array" then "@[%a.(%a)@]" else "@[%a.[%a]@]" in
+              pp f fmt   self#simple_expr e1 self#expression e2;
+              true
+            end
+    |Pexp_apply
+        ({pexp_desc=
+          Pexp_ident
+            {txt= Ldot (Lident (("Array"|"String") as s),
+                        "set");_};_},[(_,e1);(_,e2);(_,e3)])
+      ->
+        let fmt :(_,_,_) format=
+          if s= "Array" then
+            "@[%a.(%a)@ <-@;%a@]"
+          else
+            "@[%a.[%a]@ <-@;%a@]" in  (* @;< gives error here *)
+        pp f fmt self#simple_expr e1  self#expression e2  self#expression e3;
+        true
+    | Pexp_apply ({pexp_desc=Pexp_ident {txt=Lident "!";_};_}, [(_,e)]) -> begin
+        pp f "@[!%a@]" self#simple_expr e;
+        true
+    end
+    | Pexp_apply
+        ({pexp_desc=Pexp_ident
+                     {txt= Ldot (Ldot (Lident "Bigarray", array), ("get"|"set" as gs)) ;_};_},
+         label_exprs) ->
+           begin match array,gs with
+           | "Genarray","get"   ->
+               begin match label_exprs with
+               | [(_,a);(_,{pexp_desc=Pexp_array ls;_})]  -> begin
+                   pp f "@[%a.{%a}@]" self#simple_expr a
+                   (self#list ~sep:"," self#simple_expr ) ls;
+                   true
+               end
+               | _ -> false
+               end
+           | "Genarray","set" ->
+               begin match label_exprs with
+               | [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)]  -> begin
+                   pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a
+                   (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c;
+                   true
+               end
+               | _ -> false
+               end
+           | ("Array1"|"Array2"|"Array3"),"set" ->
+               begin
+                 match label_exprs with
+                 | (_,a)::rest ->
+                     begin match List.rev rest with
+                     | (_,v)::rest ->
+                         let args = List.map snd (List.rev rest) in
+                         pp f "@[%a.{%a}@ <-@ %a@]"
+                           self#simple_expr a (self#list ~sep:"," self#simple_expr)
+                           args self#simple_expr v;
+                         true
+                     | _ -> assert false
+                     end
+                 | _ -> assert false
+               end
+           | ("Array1"|"Array2"|"Array3"),"get" ->
+               begin match label_exprs with
+               |(_,a)::rest ->
+                 pp f "@[%a.{%a}@]"
+                     self#simple_expr a (self#list ~sep:"," self#simple_expr)
+                     (List.map snd rest);
+                   true
+               | _ -> assert false
+               end
+           | _ -> false
+           end
+
+    | _ -> false
+  method expression f x =
+    match x.pexp_desc with
+    | Pexp_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+      when pipe || semi ->
+        self#paren true self#reset#expression f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
+        self#paren true self#reset#expression f x
+    | Pexp_let _ | Pexp_letmodule _ when semi ->
+        self#paren true self#reset#expression f x
+    | Pexp_function _(* (p, eo, l) *) ->
+        let rec aux acc = function
+          | {pexp_desc = Pexp_function (l,eo, [(p',e')]);_}
+              -> aux ((l,eo,p')::acc) e'
+          | x -> (List.rev acc,x)  in
+        begin match aux [] x with
+        | [], {pexp_desc=Pexp_function(_label,_eo,l);_} -> (* label should be "" *)
+            pp f "@[function%a@]" self#case_list l
+        | ls, {pexp_desc=Pexp_when(e1,e2);_}->
+            pp f "@[<2>fun@;%a@;when@;%a@;->@;%a@]"
+            (self#list
+               (fun f (l,eo,p) ->
+                 self#label_exp  f (l,eo,p) )) ls
+              self#reset#expression e1 self#expression e2
+        | ls, e ->
+            pp f "@[<2>fun@;%a@;->@;%a@]"
+              (self#list
+                 (fun f (l,eo,p) ->
+                   self#label_exp f (l,eo,p))) ls
+              self#expression e end
+    | Pexp_match (e, l) ->
+        pp f "@[@[@[<2>match %a@]@ with@]%a@]" self#reset#expression e self#case_list l
+
+    | Pexp_try (e, l) ->
+        pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          self#reset#expression e  self#case_list l
+    | Pexp_let (rf, l, e) ->
+        (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" (\*no identation here, a new line*\) *)
+        (*   self#rec_flag rf *)
+        pp f "@[<2>%a in@;<1 -2>%a@]"
+          self#reset#bindings (rf,l)
+          self#expression e
+    | Pexp_apply (e, l) ->
+        (if not (self#sugar_expr f x) then
+          match view_fixity_of_exp e with
+          | `Infix s ->
+            (match l with
+            | [ arg1; arg2 ] ->
+                pp f "@[<2>%a@;%s@;%a@]" (* FIXME associativity lable_x_expression_parm*)
+                  self#reset#label_x_expression_param  arg1 s  self#label_x_expression_param arg2
+            | _ ->
+                pp f "@[<2>%a %a@]" self#simple_expr e  (self#list self#label_x_expression_param)  l)
+          | `Prefix s ->
+              let s =
+                if List.mem s ["~+";"~-";"~+.";"~-."] then String.sub s 1 (String.length s -1)
+                else s in
+            (match l with
+            |[v] -> pp f "@[<2>%s@;%a@]" s self#label_x_expression_param v
+            | _ -> pp f "@[<2>%s@;%a@]" s (self#list self#label_x_expression_param) l  (*FIXME assert false*)
+            )
+          | _ ->
+            pp f "@[%a@]" begin fun f (e,l) ->
+              pp f "%a@ %a" self#expression2 e
+                (self#list self#reset#label_x_expression_param)  l
+               (*reset here only because [function,match,try,sequence] are lower priority*)
+            end (e,l))
+
+    | Pexp_construct (li, Some eo, _)
+      when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
+        (match view_expr x with
+        | `cons ls -> self#list self#simple_expr f ls ~sep:"@;::@;"
+        | `normal ->
+            pp f "@[<2>%a@;%a@]" self#longident_loc li
+              self#simple_expr  eo
+        | _ -> assert false)
+    | Pexp_setfield (e1, li, e2) ->
+        pp f "@[<2>%a.%a@ <-@ %a@]" self#simple_expr  e1  self#longident_loc li self#expression e2;
+    | Pexp_ifthenelse (e1, e2, eo) ->
+        (* @;@[<2>else@ %a@]@] *)
+        let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
+        pp f fmt  self#under_ifthenelse#expression e1 self#under_ifthenelse#expression e2
+          (fun f eo -> match eo with
+          | Some x -> pp f "@;@[<2>else@;%a@]" self#under_semi#expression  x
+          | None -> () (* pp f "()" *)) eo
+    | Pexp_sequence _ ->
+        let rec sequence_helper acc = function
+          | {pexp_desc=Pexp_sequence(e1,e2);_} ->
+              sequence_helper (e1::acc) e2
+          | v -> List.rev (v::acc) in
+        let lst = sequence_helper [] x in
+        pp f "@[%a@]"
+          (self#list self#under_semi#expression ~sep:";@;") lst
+    | Pexp_when (_e1, _e2) ->  assert false (*FIXME handled already in pattern *)
+    | Pexp_new (li) ->
+        pp f "@[new@ %a@]" self#longident_loc li;
+    | Pexp_setinstvar (s, e) ->
+        pp f "@[%s@ <-@ %a@]" s.txt self#expression e
+    | Pexp_override l -> (* FIXME *)
+        let string_x_expression f (s, e) =
+          pp f "@[%s@ =@ %a@]" s.txt self#expression e in
+        pp f "@[{<%a>}@]"
+          (self#list string_x_expression  ~sep:";"  )  l;
+    | Pexp_letmodule (s, me, e) ->
+        pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
+          self#reset#module_expr me  self#expression e
+    | Pexp_assert e ->
+        pp f "@[assert@ %a@]" self#simple_expr e
+    | Pexp_assertfalse ->
+        pp f "@[<2>assert@;false@]" ;
+    | Pexp_lazy (e) ->
+        pp f "@[lazy@ %a@]" self#simple_expr e
+    | Pexp_poly _ ->
+        assert false
+    | Pexp_open (ovf, lid, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid
+          self#expression  e
+    | Pexp_variant (l,Some eo) ->
+        pp f "@[<2>`%s@;%a@]" l  self#simple_expr eo
+    | _ -> self#expression1 f x
+  method expression1 f x =
+    match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" self#class_structure cs
+    | _ -> self#expression2 f x
+  (* used in [Pexp_apply] *)
+  method expression2 f x =
+    match x.pexp_desc with
+    | Pexp_field (e, li) -> pp f "@[%a.%a@]" self#simple_expr e self#longident_loc li
+    | Pexp_send (e, s) ->  pp f "@[%a#%s@]" self#simple_expr e  s
+
+    | _ -> self#simple_expr f x
+  method simple_expr f x =
+    match x.pexp_desc with
+    | Pexp_construct _  when is_simple_construct (view_expr x) ->
+        (match view_expr x with
+        | `nil -> pp f "[]"
+        | `tuple -> pp f "()"
+        | `list xs -> pp f "@[[%a]@]"  (self#list self#under_semi#expression ~sep:";@;") xs
+        | `simple x -> self#longident f x
+        | _ -> assert false)
+    | Pexp_ident li ->
+        self#longident_loc f li
+        (* (match view_fixity_of_exp x with *)
+        (* |`Normal -> self#longident_loc f li *)
+        (* | `Prefix _ | `Infix _ -> pp f "( %a )" self#longident_loc li) *)
+    | Pexp_constant c -> self#constant f c;
+    | Pexp_pack me ->
+        pp f "(module@;%a)"  self#module_expr me
+    | Pexp_newtype (lid, e) ->
+        pp f "fun@;(type@;%s)@;->@;%a"  lid  self#expression  e
+    | Pexp_tuple l ->
+        pp f "@[(%a)@]"  (self#list self#simple_expr  ~sep:",@;")  l
+    | Pexp_constraint (e, cto1, cto2) ->
+        pp f "(%a%a%a)" self#expression e
+          (self#option self#core_type ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (self#option self#core_type ~first:" :>") cto2
+    | 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 ->
+              pp f "@[%a@]" self#longident_loc li
+          | _ ->
+              pp f "@[%a@;=@;%a@]" self#longident_loc li self#simple_expr e in
+        pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *)
+          (self#option ~last:" with@;" self#simple_expr) eo
+          (self#list longident_x_expression ~sep:";@;")  l
+    | Pexp_array (l) ->
+        pp f "@[<0>@[<2>[|%a|]@]@]"
+          (self#list self#under_semi#simple_expr ~sep:";") l
+    | Pexp_while (e1, e2) ->
+        let fmt:(_,_,_)format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt self#expression e1 self#expression e2
+    | Pexp_for (s, e1, e2, df, e3) ->
+        let fmt:(_,_,_)format =
+          "@[@[@[<2>for %s =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
+        pp f fmt s.txt self#expression e1 self#direction_flag df self#expression e2  self#expression e3
+    | _ ->  self#paren true self#expression f x
+
+
+  method value_description f x =
+    pp f "@[%a%a@]" self#core_type x.pval_type
+      (fun f x ->
+        if x.pval_prim<>[] then begin
+          pp f "@ =@ %a"
+            (self#list self#constant_string)
+            x.pval_prim ;
+        end) x
+
+
+  method exception_declaration f (s,ed) =
+    pp f "@[exception@ %s%a@]" s
+      (fun f ed -> match ed with
+      |[] -> ()
+      |_ -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) ed) ed
+
+
+  method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
+    let class_type_field f x =
+      match x.pctf_desc with
+      | Pctf_inher (ct) ->
+          pp f "@[<2>inherit@ %a@]" self#class_type ct
+      | Pctf_val (s, mf, vf, ct) ->
+          pp f "@[<2>val @ %a%a%s@ :@ %a@]"
+            self#mutable_flag mf self#virtual_flag vf s  self#core_type  ct
+      | Pctf_virt (s, pf, ct) ->    (* todo: test this *)
+          pp f "@[<2>method@ %a@ virtual@ %s@ :@ %a@]"
+            self#private_flag pf s  self#core_type ct
+      | Pctf_meth (s, pf, ct) ->
+          pp f "@[<2>method %a%s :@;%a@]"
+            self#private_flag pf s self#core_type ct
+      | Pctf_cstr (ct1, ct2) ->
+          pp f "@[<2>constraint@ %a@ =@ %a@]"
+            self#core_type ct1 self#core_type ct2 in
+    pp f "@[@[object @[<1>%a@]@ %a@]@ end@]"
+      (fun f ct -> match ct.ptyp_desc with
+      | Ptyp_any -> ()
+      | _ -> pp f "(%a)" self#core_type ct) ct
+      (self#list   class_type_field ~sep:"@;") l  ;
+
+  (* call [class_signature] called by [class_signature] *)
+  method class_type f x =
+    match x.pcty_desc with
+    | Pcty_signature cs -> self#class_signature f cs;
+    | Pcty_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l -> match l with
+          | [] -> ()
+          | _  -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l
+          self#longident_loc li
+    | Pcty_fun (l, co, cl) ->
+        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+          self#type_with_label (l,co) self#class_type cl
+
+
+  (* [class type a = object end] *)
+  method class_type_declaration_list f  l =
+    let class_type_declaration f ({pci_params=(ls,_);pci_name={txt;_};pci_variance;_} as x) =
+      pp f "%a%a%s@ =@ %a" self#virtual_flag x.pci_virt
+        self#class_params_def (List.combine ls pci_variance) txt
+        self#class_type x.pci_expr in
+    match l with
+    | [] -> ()
+    | [h] -> pp f "@[class type %a@]" class_type_declaration   h
+    | _ ->
+        pp f "@[<2>class type %a@]"
+          (self#list class_type_declaration ~sep:"@]@;@[<2>and@;") l
+
+  method class_field f x =
+    match x.pcf_desc with
+    | Pcf_inher (ovf, ce, so) ->
+        pp f "@[<2>inherit@ %s@ %a%a@]"  (override ovf) self#class_expr ce
+          (fun f so -> match so with
+          | None -> ();
+          | Some (s) -> pp f "@ as %s" s ) so
+    | Pcf_val (s, mf, ovf, e) ->
+        pp f "@[<2>val%s %a%s =@;%a@]" (override ovf)  self#mutable_flag mf
+          s.txt  self#expression  e
+    | Pcf_virt (s, pf, ct) ->
+        pp f "@[<2>method virtual %a %s :@;%a@]"
+          self#private_flag pf s.txt self#core_type  ct
+    | Pcf_valvirt (s, mf, ct) ->
+        pp f "@[<2>val virtual %a%s :@ %a@]"
+          self#mutable_flag mf s.txt
+          self#core_type  ct
+    | Pcf_meth (s, pf, ovf, e) ->
+        pp f "@[<2>method%s %a%a@]"
+          (override ovf)
+          self#private_flag pf
+          (fun f e -> match e.pexp_desc with
+          | Pexp_poly (e, Some ct) ->
+              pp f "%s :@;%a=@;%a"
+                s.txt (self#core_type) ct self#expression e
+          | Pexp_poly (e,None) ->
+              self#binding f ({ppat_desc=Ppat_var s;ppat_loc=Location.none} ,e)
+          | _ ->
+              self#expression f e ) e
+    | Pcf_constr (ct1, ct2) ->
+        pp f "@[<2>constraint %a =@;%a@]" self#core_type  ct1 self#core_type  ct2
+    | Pcf_init (e) ->
+        pp f "@[<2>initializer@ %a@]" self#expression e
+
+  method class_structure f { pcstr_pat = p; pcstr_fields =  l } =
+    pp f "@[@[object %a@;%a@]@;end@]"
+      (fun f p -> match p.ppat_desc with
+      | Ppat_any -> ()
+      | Ppat_constraint _ -> pp f "%a"  self#pattern  p
+      | _ -> pp f "(%a)" self#pattern p) p
+      (self#list self#class_field ) l
+
+  method class_expr f x =
+    match x.pcl_desc with
+    | Pcl_structure (cs) ->  self#class_structure f cs ;
+    | Pcl_fun (l, eo, p, e) ->
+        pp f "fun@ %a@ ->@ %a" self#label_exp (l,eo,p)  self#class_expr e
+    | Pcl_let (rf, l, ce) ->
+        (* pp f "let@;%a%a@ in@ %a" *)
+          pp f "%a@ in@ %a"
+          (* self#rec_flag rf *)
+          self#bindings  (rf,l)
+          self#class_expr ce
+    | Pcl_apply (ce, l) ->
+        pp f "(%a@ %a)"  self#class_expr ce (self#list self#label_x_expression_param) l
+    | Pcl_constr (li, l) ->
+        pp f "%a%a"
+          (fun f l-> if l <>[] then
+            pp f "[%a]@ "
+              (self#list self#core_type  ~sep:"," ) l ) l
+          self#longident_loc li
+    | Pcl_constraint (ce, ct) ->
+        pp f "(%a@ :@ %a)"
+          self#class_expr ce
+          self#class_type ct
+
+
+
+  method module_type f x =
+    match x.pmty_desc with
+    | Pmty_ident li ->
+        pp f "%a" self#longident_loc li;
+    | Pmty_signature (s) ->
+        pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *)
+          (self#list self#signature_item  ) s (* FIXME wrong indentation*)
+    | Pmty_functor (s, mt1, mt2) ->
+        pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
+          self#module_type mt1  self#module_type mt2
+    | Pmty_with (mt, l) ->
+        let longident_x_with_constraint f (li, wc) =
+          match wc with
+          | Pwith_type ({ptype_params= ls ;_} as td) ->
+              pp f "type@ %a %a =@ %a"
+                (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
+                ls self#longident_loc li  self#type_declaration  td
+          | Pwith_module (li2) ->
+              pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
+          | Pwith_typesubst ({ptype_params=ls;_} as td) ->
+              pp f "type@ %a %a :=@ %a"
+                (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
+                ls self#longident_loc li
+                self#type_declaration  td
+          | Pwith_modsubst (li2) ->
+              pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
+        (match l with
+        | [] -> pp f "@[%a@]" self#module_type mt
+        | _ -> pp f "@[(%a@ with@ %a)@]"
+              self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
+    | Pmty_typeof me ->
+        pp f "@[module@ type@ of@ %a@]"
+          self#module_expr me
+  method signature f x =  self#list ~sep:"@\n" self#signature_item f x
+
+  method signature_item f x :unit= begin
+    match x.psig_desc with
+    | Psig_type l ->
+        self#type_def_list f l
+    | Psig_value (s, vd) ->
+        pp f "@[<2>%a@]"
+          (fun f (s,vd) ->
+            let intro = if vd.pval_prim = [] then "val" else "external" in
+            if (is_infix (fixity_of_string s.txt)) || List.mem s.txt.[0] prefix_symbols then
+              pp f "%s@ (@ %s@ )@ :@ " intro s.txt
+            else
+              pp f "%s@ %s@ :@ " intro s.txt;
+            self#value_description f vd;) (s,vd)
+    | Psig_exception (s, ed) ->
+        self#exception_declaration f (s.txt,ed)
+    | Psig_class l ->
+        let class_description f ({pci_params=(ls,_);pci_name={txt;_};pci_variance;_} as x) =
+          pp f "%a%a%s@;:@;%a" (* "@[<2>class %a%a%s@;:@;%a@]" *)
+            self#virtual_flag x.pci_virt
+            self#class_params_def
+            (List.combine ls pci_variance)
+            txt  self#class_type x.pci_expr in
+        pp f  "@[<0>%a@]"
+          (fun f l ->  match l with
+            |[]  ->()
+            |[x] -> pp f "@[<2>class %a@]" class_description x
+            |_ -> self#list ~first:"@[class @[<2>" ~sep:"@]@;and @[" ~last:"@]@]"
+                  class_description f l) l
+    | Psig_module (s, mt) ->
+        pp f "@[module@ %s@ :@ %a@]"
+          s.txt
+          self#module_type  mt
+    | Psig_open (ovf, li) ->
+        pp f "@[open%s@ %a@]" (override ovf) self#longident_loc li
+    | Psig_include (mt) ->
+        pp f "@[include@ %a@]"
+          self#module_type  mt
+    | Psig_modtype (s, md) ->
+        pp f "@[module@ type@ %s%a@]"
+          s.txt
+          (fun f md -> match md with
+          | Pmodtype_abstract -> ()
+          | Pmodtype_manifest (mt) ->
+              pp_print_space f () ;
+              pp f "@ =@ %a"  self#module_type mt
+          ) md
+    | Psig_class_type (l) ->
+        self#class_type_declaration_list f l ;
+    | Psig_recmodule decls ->
+        let rec  string_x_module_type_list f ?(first=true) l =
+          match l with
+          | [] -> () ;
+          | (s,mty) :: tl ->
+              if not first then
+                pp f "@ @[and@ %s:@ %a@]"
+                  s.txt self#module_type mty
+              else
+                pp f "@ @[module@ rec@ %s:@ %a@]"
+                  s.txt self#module_type mty;
+              string_x_module_type_list f ~first:false tl  in
+        string_x_module_type_list f decls
+  end
+  method module_expr f x =
+    match x.pmod_desc with
+    | Pmod_structure (s) ->
+        pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]"
+          (self#list self#structure_item  ~sep:"@\n") s;
+    | Pmod_constraint (me, mt) ->
+        pp f "@[(%a@ :@ %a)@]"
+          self#module_expr  me
+          self#module_type mt
+    | Pmod_ident (li) ->
+        pp f "%a" self#longident_loc li;
+    | Pmod_functor (s, mt, me) ->
+        pp f "functor@ (%s@ :@ %a)@;->@;%a"
+          s.txt  self#module_type mt  self#module_expr me
+    | Pmod_apply (me1, me2) ->
+        pp f "%a(%a)" self#module_expr me1  self#module_expr  me2
+    | Pmod_unpack e ->
+        pp f "(val@ %a)"  self#expression  e
+
+  method structure f x = self#list ~sep:"@\n" self#structure_item f x
+
+  (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+  method binding f ((p:pattern),(x:expression)) =
+    let rec pp_print_pexp_function f x =
+      match x.pexp_desc with
+      | Pexp_function (label,eo,[(p,e)]) ->
+          if label="" then
+            match e.pexp_desc with
+            | Pexp_when _  -> pp f "=@;%a" self#expression x
+            | _ ->
+                pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
+          else
+            pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
+      | Pexp_newtype (str,e) ->
+          pp f "(type@ %s)@ %a" str pp_print_pexp_function e
+      | _ -> pp f "=@;%a" self#expression x in
+    match (x.pexp_desc,p.ppat_desc) with
+    | (Pexp_when (e1,e2),_) ->
+        pp f "=@[<2>fun@ %a@ when@ %a@ ->@ %a@]"
+          self#simple_pattern p self#expression e1 self#expression e2
+    | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
+        (match ty.ptyp_desc with
+        | Ptyp_poly _ ->
+            pp f "%a@;:@;%a=@;%a" self#simple_pattern p  self#core_type ty self#expression x
+        | _ ->
+            pp f "(%a@;:%a)=@;%a" self#simple_pattern p  self#core_type ty self#expression x)
+    | Pexp_constraint (e,Some t1,None),Ppat_var {txt;_} ->
+        pp f "%s:@ %a@;=@;%a" txt self#core_type t1  self#expression e
+    | (_, Ppat_var _) ->
+        pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x
+    | _ ->
+        pp f "%a@;=@;%a" self#pattern p self#expression x
+  (* [in] is not printed *)
+  method bindings f (rf,l) =
+    begin match l with
+    | [] -> ()
+    | [x] -> pp f "@[<2>let %a%a@]" self#rec_flag rf self#binding x
+    | x::xs ->
+        (* pp f "@[let %a@[<2>%a%a@]" *)
+        (* FIXME the indentation is not good see [Insert].ml*)
+        pp f "@[@[<2>let %a%a%a@]"
+          self#rec_flag rf  self#binding x
+          (fun f l -> match l with
+          | [] -> assert false
+          | [x] ->
+              pp f
+                (* "@]@;and @[<2>%a@]" *)
+                "@]@;@[<2>and %a@]"
+                self#binding x
+          | xs ->
+              self#list self#binding
+                (* ~first:"@]@;and @[<2>" *)
+                ~first:"@]@;@[<2>and "
+                (* ~sep:"@]@;and @[<2>" *)
+                ~sep:"@]@;@[<2>and "
+                ~last:"@]" f xs )  xs
+    end
+
+  method structure_item f x = begin
+    match x.pstr_desc with
+    | Pstr_eval (e) ->
+        pp f "@[let@ _ =@ %a@]" self#expression e
+    | Pstr_type [] -> assert false
+    | Pstr_type l  -> self#type_def_list f l
+    | Pstr_value (rf, l) -> (* pp f "@[let %a%a@]"  self#rec_flag rf self#bindings l *)
+        pp f "@[<2>%a@]" self#bindings (rf,l)
+    | Pstr_exception (s, ed) -> self#exception_declaration f (s.txt,ed)
+    | Pstr_module (s, me) ->
+        let rec module_helper me = match me.pmod_desc with
+        | Pmod_functor(s,mt,me) ->
+            pp f "(%s:%a)"  s.txt  self#module_type mt ;
+            module_helper me
+        | _ -> me in
+        pp f "@[module %s%a@]"
+          s.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)) ->
+                pp f " :@;%a@;=@;%a@;"  self#module_type mt self#module_expr  me
+            | _ ->
+                pp f " =@ %a"  self#module_expr  me
+            )) me
+    | Pstr_open (ovf, li) ->
+        pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li;
+    | Pstr_modtype (s, mt) ->
+        pp f "@[<2>module type %s =@;%a@]" s.txt self#module_type mt
+    | Pstr_class l ->
+        let class_declaration f  (* for the second will be changed to and FIXME*)
+            ({pci_params=(ls,_);
+              pci_name={txt;_};
+              pci_virt;
+              pci_expr={pcl_desc;_};
+              pci_variance;_ } as x) =
+          let ls = List.combine ls pci_variance in
+          let rec  class_fun_helper f e = match e.pcl_desc with
+          | Pcl_fun (l, eo, p, e) ->
+              self#label_exp f (l,eo,p);
+              class_fun_helper f e
+          | _ -> e in
+          pp f "%a%a%s %a"  self#virtual_flag pci_virt self#class_params_def ls txt
+            (fun f _ ->
+              let ce =
+                (match pcl_desc with
+                | Pcl_fun _ ->
+                    class_fun_helper f x.pci_expr;
+                | _ -> x.pci_expr) in
+              let ce =
+                (match ce.pcl_desc with
+                | Pcl_constraint (ce, ct) ->
+                    pp f ": @[%a@] " self#class_type  ct ;
+                    ce
+                | _ -> ce ) in
+              pp f "=@;%a" self#class_expr ce ) x in
+        (match l with
+        | [] -> ()
+        | [x] -> pp f "@[<2>class %a@]" class_declaration x
+        | xs ->  self#list
+              ~first:"@[class @[<2>"
+              ~sep:"@]@;and @["
+              ~last:"@]@]" class_declaration f xs)
+    | Pstr_class_type (l) ->
+        self#class_type_declaration_list f l ;
+    | Pstr_primitive (s, vd) ->
+        let need_parens =
+          match s.txt with
+          | "or" | "mod" | "land"| "lor" | "lxor" | "lsl" | "lsr" | "asr" -> true
+          | _ -> match s.txt.[0] with
+              'a'..'z' -> false | _ -> true in
+        pp f "@[external@ %s@ :@ %a@]"
+          (if need_parens then "( "^s.txt^" )" else s.txt)
+          self#value_description  vd
+    | Pstr_include me ->
+        pp f "@[include@ %a@]"  self#module_expr  me
+    | Pstr_exn_rebind (s, li) ->        (* todo: check this *)
+        pp f "@[exception@ %s@ =@ %a@]" s.txt self#longident_loc li
+    | Pstr_recmodule decls -> (* 3.07 *)
+        let text_x_modtype_x_module f (s, mt, me) =
+          pp f "@[and@ %s:%a@ =@ %a@]"
+            s.txt self#module_type mt self#module_expr me
+        in match decls with
+        | (s,mt,me):: l2 ->
+            pp f "@[@[module@ rec@ %s:%a@ =@ %a@]@ %a@]"
+              s.txt
+              self#module_type mt
+              self#module_expr me
+              (fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2
+        | _ -> assert false
+  end
+  method type_param f  = function
+    | (a,opt) -> pp f "%s%a" (type_variance a ) self#type_var_option opt
+          (* shared by [Pstr_type,Psig_type]*)
+  method  type_def_list f  l =
+    let aux f (s, ({ptype_params;ptype_kind;ptype_manifest;ptype_variance;_} as td )) =
+      let ptype_params = List.combine  ptype_variance ptype_params in
+      pp f "%a%s%a"
+        (fun f l -> match l with
+        |[] -> ()
+        | _ ->  pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l)
+        ptype_params s.txt
+        (fun f td ->begin match ptype_kind, ptype_manifest with
+        | Ptype_abstract, None -> ()
+        | _ , _ -> pp f " =@;" end;
+          pp f "%a" self#type_declaration td ) td  in
+    match l with
+    | [] -> () ;
+    | [x] -> pp f "@[<2>type %a@]" aux x
+    | xs -> pp f "@[@[<2>type %a"
+          (self#list aux ~sep:"@]@,@[<2>and " ~last:"@]@]") xs
+          (* called by type_def_list *)
+  method type_declaration f x = begin
+    let  type_variant_leaf f  (s, l,gadt, _loc)  = match gadt with
+    |None ->
+        pp f "@\n|@;%s%a" s.txt
+          (fun f l -> match l with
+          | [] -> ()
+          | _ -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l) l
+    |Some x ->
+        pp f "@\n|@;%s:@;%a" s.txt
+          (self#list self#core_type1 ~sep:"@;->@;") (l@[x]) in
+    pp f "%a%a@ %a"
+      (fun f x -> match (x.ptype_manifest,x.ptype_kind,x.ptype_private) with
+      | (None,_,Public) ->  pp f "@;"
+      | (None,Ptype_abstract,Private) -> pp f "@;" (* private type without print*)
+      | (None,_,Private) -> pp f "private@;"
+      | (Some y, Ptype_abstract,Private) ->
+          pp f "private@;%a" self#core_type y;
+      | (Some y, _, Private) ->
+          pp f "%a = private@;" self#core_type y
+      | (Some y,Ptype_abstract, Public) ->  self#core_type f y;
+      | (Some y, _,Public) -> begin
+          pp f "%a =@;" self#core_type y (* manifest types*)
+      end) x
+      (fun f x -> match x.ptype_kind with
+        (*here only normal variant types allowed here*)
+      | Ptype_variant xs ->
+          pp f "%a"
+            (self#list ~sep:"" type_variant_leaf) xs
+      | Ptype_abstract -> ()
+      | Ptype_record l ->
+          let type_record_field f (s, mf, ct,_) =
+            pp f "@[<2>%a%s:@;%a@]" self#mutable_flag mf s.txt self#core_type ct in
+          pp f "{@\n%a}"
+            (self#list type_record_field ~sep:";@\n" )  l ;
+      ) x
+      (self#list
+         (fun f (ct1,ct2,_) ->
+           pp f "@[constraint@ %a@ =@ %a@]"
+             self#core_type ct1 self#core_type ct2 ))  x.ptype_cstrs  ;
+  end
+  method case_list f (l:(pattern * expression) list) :unit=
+    let aux f (p,e) =
+      let (e,w) =
+        (match e with
+        | {pexp_desc = Pexp_when (e1, e2);_} -> (e2, Some (e1))
+        | _ -> (e, None)) in
+      pp f "@;| @[<2>%a%a@;->@;%a@]"
+        self#pattern p (self#option self#expression ~first:"@;when@;") w self#under_pipe#expression e in
+    self#list aux f l ~sep:""
+  method label_x_expression_param f (l,e) =
+    match l with
+    | ""  -> self#expression2 f e ; (* level 2*)
+    | lbl ->
+        let simple_name = match e.pexp_desc with
+        | Pexp_ident {txt=Lident l;_} -> Some l
+        | _ -> None in
+        if  lbl.[0] = '?' then
+          let str = String.sub lbl 1 (String.length lbl-1) in
+          if Some str = simple_name then
+            pp f "%s" lbl
+          else
+            pp f "%s:%a" lbl self#simple_expr e
+        else
+          if Some lbl = simple_name then
+            pp f "~%s" lbl
+          else
+            pp f "~%s:%a" lbl self#simple_expr e
+
+  method directive_argument f x =
+    (match x with
+    | Pdir_none -> ()
+    | Pdir_string (s) -> pp f "@ %S" s
+    | Pdir_int (i) -> pp f "@ %d" i
+    | Pdir_ident (li) -> pp f "@ %a" self#longident li
+    | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
+
+  method toplevel_phrase f x =
+    match x with
+    | Ptop_def (s) ->
+        pp_open_hvbox f 0;
+        self#list self#structure_item f s ;
+        pp_close_box f ();
+    | Ptop_dir (s, da) ->
+        pp f "@[#%s@ %a@]" s self#directive_argument da
+end;;
+
+
+let default = new printer ()
+
+
+let toplevel_phrase f x =
+  match x with
+  | Ptop_def (s) ->pp f "@[%a@]"  (default#list default#structure_item) s
+   (* pp_open_hvbox f 0; *)
+   (* pp_print_list structure_item f s ; *)
+   (* pp_close_box f (); *)
+  | Ptop_dir (s, da) ->
+   pp f "@[#%s@ %a@]" s default#directive_argument da
+   (* pp f "@[#%s@ %a@]" s directive_argument da *)
+
+let expression f x =
+  pp f "@[%a@]" default#expression x
+
+
+let string_of_expression x =
+  ignore (flush_str_formatter ()) ;
+  let f = str_formatter in
+  default#expression f x ;
+  flush_str_formatter () ;;
+let string_of_structure x =
+  ignore (flush_str_formatter ());
+  let f = str_formatter in
+  default#structure f x;
+  flush_str_formatter ();;
+
+let top_phrase f x =
+  pp_print_newline f () ;
+  toplevel_phrase f x;
+  pp f ";;" ;
+  pp_print_newline f ();;
+
+let core_type=default#core_type
+let pattern=default#pattern
+let signature=default#signature
+let structure=default#structure
diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
new file mode 100644
index 00000000..e84ee030
--- /dev/null
+++ b/parsing/pprintast.mli
@@ -0,0 +1,129 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Hongbo Zhang (University of Pennsylvania)                *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+type space_formatter = (unit, Format.formatter, unit) format
+class printer :
+  unit ->
+  object ('b)
+    val pipe : bool
+    val semi : bool
+    method binding :
+      Format.formatter -> Parsetree.pattern * Parsetree.expression -> unit
+    method bindings:
+        Format.formatter ->
+          Asttypes.rec_flag * (Parsetree.pattern * Parsetree.expression) list ->
+            unit
+    method case_list :
+      Format.formatter ->
+      (Parsetree.pattern * Parsetree.expression) list -> unit
+    method class_expr : Format.formatter -> Parsetree.class_expr -> unit
+    method class_field : Format.formatter -> Parsetree.class_field -> unit
+    method class_params_def :
+      Format.formatter -> (string Asttypes.loc * (bool * bool)) list -> unit
+    method class_signature :
+      Format.formatter -> Parsetree.class_signature -> unit
+    method class_structure :
+      Format.formatter -> Parsetree.class_structure -> unit
+    method class_type : Format.formatter -> Parsetree.class_type -> unit
+    method class_type_declaration_list :
+      Format.formatter -> Parsetree.class_type_declaration list -> unit
+    method constant : Format.formatter -> Asttypes.constant -> unit
+    method constant_string : Format.formatter -> string -> unit
+    method core_type : Format.formatter -> Parsetree.core_type -> unit
+    method core_type1 : Format.formatter -> Parsetree.core_type -> unit
+    method direction_flag :
+      Format.formatter -> Asttypes.direction_flag -> unit
+    method directive_argument :
+      Format.formatter -> Parsetree.directive_argument -> unit
+    method exception_declaration :
+      Format.formatter -> string * Parsetree.exception_declaration -> unit
+    method expression : Format.formatter -> Parsetree.expression -> unit
+    method expression1 : Format.formatter -> Parsetree.expression -> unit
+    method expression2 : Format.formatter -> Parsetree.expression -> unit
+    method label_exp :
+      Format.formatter ->
+      Asttypes.label * Parsetree.expression option * Parsetree.pattern ->
+      unit
+    method label_x_expression_param :
+      Format.formatter -> Asttypes.label * Parsetree.expression -> unit
+    method list :
+      ?sep:space_formatter ->
+      ?first:space_formatter ->
+      ?last:space_formatter ->
+      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
+    method longident : Format.formatter -> Longident.t -> unit
+    method longident_loc :
+      Format.formatter -> Longident.t Asttypes.loc -> unit
+    method module_expr : Format.formatter -> Parsetree.module_expr -> unit
+    method module_type : Format.formatter -> Parsetree.module_type -> unit
+    method mutable_flag : Format.formatter -> Asttypes.mutable_flag -> unit
+    method option :
+      ?first:space_formatter ->
+      ?last:space_formatter ->
+      (Format.formatter -> 'a -> unit) ->
+      Format.formatter -> 'a option -> unit
+    method paren :
+        ?first:space_formatter -> ?last:space_formatter -> bool ->
+          (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+    method pattern : Format.formatter -> Parsetree.pattern -> unit
+    method pattern1 : Format.formatter -> Parsetree.pattern -> unit
+    method private_flag : Format.formatter -> Asttypes.private_flag -> unit
+    method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
+
+    method reset : 'b
+    method reset_semi : 'b
+    method reset_ifthenelse : 'b
+    method reset_pipe : 'b
+
+    method signature :
+      Format.formatter -> Parsetree.signature_item list -> unit
+    method signature_item :
+      Format.formatter -> Parsetree.signature_item -> unit
+    method simple_expr : Format.formatter -> Parsetree.expression -> unit
+    method simple_pattern : Format.formatter -> Parsetree.pattern -> unit
+    method string_quot : Format.formatter -> Asttypes.label -> unit
+    method structure :
+      Format.formatter -> Parsetree.structure_item list -> unit
+    method structure_item :
+      Format.formatter -> Parsetree.structure_item -> unit
+    method sugar_expr : Format.formatter -> Parsetree.expression -> bool
+    method toplevel_phrase :
+      Format.formatter -> Parsetree.toplevel_phrase -> unit
+    method type_declaration :
+      Format.formatter -> Parsetree.type_declaration -> unit
+    method type_def_list :
+      Format.formatter ->
+      (string Asttypes.loc * Parsetree.type_declaration) list -> unit
+    method type_param :
+      Format.formatter -> (bool * bool) * string Asttypes.loc option -> unit
+    method type_var_option :
+      Format.formatter -> string Asttypes.loc option -> unit
+    method type_with_label :
+      Format.formatter -> Asttypes.label * Parsetree.core_type -> unit
+    method tyvar : Format.formatter -> string -> unit
+    method under_pipe : 'b
+    method under_semi : 'b
+    method under_ifthenelse : 'b
+    method value_description :
+      Format.formatter -> Parsetree.value_description -> unit
+    method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit
+  end
+val default : printer
+val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
+val expression : Format.formatter -> Parsetree.expression -> unit
+val string_of_expression : Parsetree.expression -> string
+val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit
+val core_type: Format.formatter -> Parsetree.core_type -> unit
+val pattern: Format.formatter -> Parsetree.pattern -> unit
+val signature: Format.formatter -> Parsetree.signature -> unit
+val structure: Format.formatter -> Parsetree.structure -> unit
+val string_of_structure: Parsetree.structure -> string
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 8b2f3e02..22c68ee4 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -10,23 +10,24 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printast.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Asttypes;;
 open Format;;
 open Lexing;;
 open Location;;
 open Parsetree;;
 
-let fmt_position f l =
+let fmt_position with_name f l =
+  let fname = if with_name then l.pos_fname else "" in
   if l.pos_lnum = -1
-  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
-  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
+  then fprintf f "%s[%d]" fname l.pos_cnum
+  else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol
                (l.pos_cnum - l.pos_bol)
 ;;
 
 let fmt_location f loc =
-  fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
+  let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in
+  fprintf f "(%a..%a)" (fmt_position true) loc.loc_start
+                       (fmt_position p_2nd_name) loc.loc_end;
   if loc.loc_ghost then fprintf f " ghost";
 ;;
 
@@ -38,8 +39,15 @@ let rec fmt_longident_aux f x =
       fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
 ;;
 
-let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;;
-let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
+let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;;
+
+let fmt_longident_loc f x =
+  fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc;
+;;
+
+let fmt_string_loc f x =
+  fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
+;;
 
 let fmt_constant f x =
   match x with
@@ -90,7 +98,7 @@ let fmt_private_flag f x =
 ;;
 
 let line i f s (*...*) =
-  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f "%s" (String.make ((2*i) mod 72) ' ');
   fprintf f s (*...*)
 ;;
 
@@ -111,9 +119,9 @@ let option i f ppf x =
       f (i+1) ppf x;
 ;;
 
-let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
 let string i ppf s = line i ppf "\"%s\"\n" s;;
-let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;;
+let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
 let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
 let label i ppf x = line i ppf "label=\"%s\"\n" x;;
 
@@ -132,7 +140,7 @@ let rec core_type i ppf x =
       line i ppf "Ptyp_tuple\n";
       list i core_type ppf l;
   | Ptyp_constr (li, l) ->
-      line i ppf "Ptyp_constr %a\n" fmt_longident li;
+      line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
       list i core_type ppf l;
   | Ptyp_variant (l, closed, low) ->
       line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed);
@@ -142,7 +150,7 @@ let rec core_type i ppf x =
       line i ppf "Ptyp_object\n";
       list i core_field_type ppf l;
   | Ptyp_class (li, l, low) ->
-      line i ppf "Ptyp_class %a\n" fmt_longident li;
+      line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
       list i core_type ppf l;
       list i string ppf low
   | Ptyp_alias (ct, s) ->
@@ -153,11 +161,11 @@ let rec core_type i ppf x =
         (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl;
       core_type i ppf ct;
   | Ptyp_package (s, l) ->
-      line i ppf "Ptyp_package %a\n" fmt_longident s;
+      line i ppf "Ptyp_package %a\n" fmt_longident_loc s;
       list i package_with ppf l;
 
 and package_with i ppf (s, t) =
-  line i ppf "with type %a\n" fmt_longident s;
+  line i ppf "with type %a\n" fmt_longident_loc s;
   core_type i ppf t
 
 and core_field_type i ppf x =
@@ -174,16 +182,16 @@ and pattern i ppf x =
   let i = i+1 in
   match x.ppat_desc with
   | Ppat_any -> line i ppf "Ppat_any\n";
-  | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s.txt;
+  | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s;
   | Ppat_alias (p, s) ->
-      line i ppf "Ppat_alias \"%s\"\n" s.txt;
+      line i ppf "Ppat_alias %a\n" fmt_string_loc s;
       pattern i ppf p;
   | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
   | Ppat_tuple (l) ->
       line i ppf "Ppat_tuple\n";
       list i pattern ppf l;
   | Ppat_construct (li, po, b) ->
-      line i ppf "Ppat_construct %a\n" fmt_longident li;
+      line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
       option i pattern ppf po;
       bool i ppf b;
   | Ppat_variant (l, po) ->
@@ -203,20 +211,20 @@ and pattern i ppf x =
       line i ppf "Ppat_lazy\n";
       pattern i ppf p;
   | Ppat_constraint (p, ct) ->
-      line i ppf "Ppat_constraint";
+      line i ppf "Ppat_constraint\n";
       pattern i ppf p;
       core_type i ppf ct;
   | Ppat_type (li) ->
-      line i ppf "Ppat_type";
-      longident i ppf li
+      line i ppf "Ppat_type\n";
+      longident_loc i ppf li
   | Ppat_unpack s ->
-      line i ppf "Ppat_unpack \"%s\"\n" s.txt;
+      line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
   let i = i+1 in
   match x.pexp_desc with
-  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li;
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li;
   | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
   | Pexp_let (rf, l, e) ->
       line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
@@ -242,7 +250,7 @@ and expression i ppf x =
       line i ppf "Pexp_tuple\n";
       list i expression ppf l;
   | Pexp_construct (li, eo, b) ->
-      line i ppf "Pexp_construct %a\n" fmt_longident li;
+      line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
       option i expression ppf eo;
       bool i ppf b;
   | Pexp_variant (l, eo) ->
@@ -255,11 +263,11 @@ and expression i ppf x =
   | Pexp_field (e, li) ->
       line i ppf "Pexp_field\n";
       expression i ppf e;
-      longident i ppf li;
+      longident_loc i ppf li;
   | Pexp_setfield (e1, li, e2) ->
       line i ppf "Pexp_setfield\n";
       expression i ppf e1;
-      longident i ppf li;
+      longident_loc i ppf li;
       expression i ppf e2;
   | Pexp_array (l) ->
       line i ppf "Pexp_array\n";
@@ -278,7 +286,7 @@ and expression i ppf x =
       expression i ppf e1;
       expression i ppf e2;
   | Pexp_for (s, e1, e2, df, e3) ->
-      line i ppf "Pexp_for \"%s\" %a\n" s.txt fmt_direction_flag df;
+      line i ppf "Pexp_for %a %a\n" fmt_direction_flag df fmt_string_loc s;
       expression i ppf e1;
       expression i ppf e2;
       expression i ppf e3;
@@ -294,51 +302,52 @@ and expression i ppf x =
   | Pexp_send (e, s) ->
       line i ppf "Pexp_send \"%s\"\n" s;
       expression i ppf e;
-  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li;
   | Pexp_setinstvar (s, e) ->
-      line i ppf "Pexp_setinstvar \"%s\"\n" s.txt;
+      line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s;
       expression i ppf e;
   | Pexp_override (l) ->
       line i ppf "Pexp_override\n";
       list i string_x_expression ppf l;
   | Pexp_letmodule (s, me, e) ->
-      line i ppf "Pexp_letmodule \"%s\"\n" s.txt;
+      line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
       module_expr i ppf me;
       expression i ppf e;
   | Pexp_assert (e) ->
-      line i ppf "Pexp_assert";
+      line i ppf "Pexp_assert\n";
       expression i ppf e;
   | Pexp_assertfalse ->
-      line i ppf "Pexp_assertfalse";
+      line i ppf "Pexp_assertfalse\n";
   | Pexp_lazy (e) ->
-      line i ppf "Pexp_lazy";
+      line i ppf "Pexp_lazy\n";
       expression i ppf e;
   | Pexp_poly (e, cto) ->
       line i ppf "Pexp_poly\n";
       expression i ppf e;
       option i core_type ppf cto;
   | Pexp_object s ->
-      line i ppf "Pexp_object";
+      line i ppf "Pexp_object\n";
       class_structure i ppf s
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype \"%s\"\n" s;
       expression i ppf e
   | Pexp_pack me ->
-      line i ppf "Pexp_pack";
+      line i ppf "Pexp_pack\n";
       module_expr i ppf me
-  | Pexp_open (m, e) ->
-      line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
+  | Pexp_open (ovf, m, e) ->
+      line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
       expression i ppf e
 
 and value_description i ppf x =
-  line i ppf "value_description\n";
+  line i ppf "value_description %a\n" fmt_location x.pval_loc;
   core_type (i+1) ppf x.pval_type;
   list (i+1) string ppf x.pval_prim;
 
 and string_option_underscore i ppf =
   function
     | Some x ->
-        string i ppf x.txt
+        string_loc i ppf x
     | None ->
         string i ppf "_"
 
@@ -373,7 +382,7 @@ and class_type i ppf x =
   let i = i+1 in
   match x.pcty_desc with
   | Pcty_constr (li, l) ->
-      line i ppf "Pcty_constr %a\n" fmt_longident li;
+      line i ppf "Pcty_constr %a\n" fmt_longident_loc li;
       list i core_type ppf l;
   | Pcty_signature (cs) ->
       line i ppf "Pcty_signature\n";
@@ -383,34 +392,32 @@ and class_type i ppf x =
       core_type i ppf co;
       class_type i ppf cl;
 
-and class_signature i ppf { pcsig_self = ct; pcsig_fields = l } =
-  line i ppf "class_signature\n";
-  core_type (i+1) ppf ct;
-  list (i+1) class_type_field ppf l;
+and class_signature i ppf cs =
+  line i ppf "class_signature %a\n" fmt_location cs.pcsig_loc;
+  core_type (i+1) ppf cs.pcsig_self;
+  list (i+1) class_type_field ppf cs.pcsig_fields;
 
 and class_type_field i ppf x =
-  let loc = x.pctf_loc in
+  line i ppf "class_type_field %a\n" fmt_location x.pctf_loc;
+  let i = i+1 in
   match x.pctf_desc with
   | Pctf_inher (ct) ->
       line i ppf "Pctf_inher\n";
       class_type i ppf ct;
   | Pctf_val (s, mf, vf, ct) ->
-      line i ppf
-        "Pctf_val \"%s\" %a %a %a\n" s
-        fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
+      line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf
+           fmt_virtual_flag vf;
       core_type (i+1) ppf ct;
   | Pctf_virt (s, pf, ct) ->
-      line i ppf
-        "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      line i ppf "Pctf_virt \"%s\" %a\n" s fmt_private_flag pf;
       core_type (i+1) ppf ct;
   | Pctf_meth (s, pf, ct) ->
-      line i ppf
-        "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      line i ppf "Pctf_meth \"%s\" %a\n" s fmt_private_flag pf;
       core_type (i+1) ppf ct;
   | Pctf_cstr (ct1, ct2) ->
-      line i ppf "Pctf_cstr %a\n" fmt_location loc;
-      core_type i ppf ct1;
-      core_type i ppf ct2;
+      line i ppf "Pctf_cstr\n";
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
 
 and class_description i ppf x =
   line i ppf "class_description %a\n" fmt_location x.pci_loc;
@@ -418,7 +425,7 @@ and class_description i ppf x =
   line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
   line i ppf "pci_params =\n";
   string_list_x_location (i+1) ppf x.pci_params;
-  line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
   line i ppf "pci_expr =\n";
   class_type (i+1) ppf x.pci_expr;
 
@@ -428,7 +435,7 @@ and class_type_declaration i ppf x =
   line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
   line i ppf "pci_params =\n";
   string_list_x_location (i+1) ppf x.pci_params;
-  line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
   line i ppf "pci_expr =\n";
   class_type (i+1) ppf x.pci_expr;
 
@@ -437,7 +444,7 @@ and class_expr i ppf x =
   let i = i+1 in
   match x.pcl_desc with
   | Pcl_constr (li, l) ->
-      line i ppf "Pcl_constr %a\n" fmt_longident li;
+      line i ppf "Pcl_constr %a\n" fmt_longident_loc li;
       list i core_type ppf l;
   | Pcl_structure (cs) ->
       line i ppf "Pcl_structure\n";
@@ -467,30 +474,31 @@ and class_structure i ppf { pcstr_pat = p; pcstr_fields = l } =
   list (i+1) class_field ppf l;
 
 and class_field i ppf x =
-  let loc = x.pcf_loc in
+  line i ppf "class_field %a\n" fmt_location x.pcf_loc;
+  let i = i + 1 in
   match x.pcf_desc with
   | Pcf_inher (ovf, ce, so) ->
       line i ppf "Pcf_inher %a\n" fmt_override_flag ovf;
       class_expr (i+1) ppf ce;
       option (i+1) string ppf so;
   | Pcf_valvirt (s, mf, ct) ->
-      line i ppf "Pcf_valvirt \"%s\" %a %a\n"
-        s.txt fmt_mutable_flag mf fmt_location loc;
+      line i ppf "Pcf_valvirt %a\n" fmt_mutable_flag mf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
       core_type (i+1) ppf ct;
   | Pcf_val (s, mf, ovf, e) ->
-      line i ppf "Pcf_val \"%s\" %a %a %a\n"
-        s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc;
+      line i ppf "Pcf_val %a %a\n" fmt_mutable_flag mf fmt_override_flag ovf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
       expression (i+1) ppf e;
   | Pcf_virt (s, pf, ct) ->
-      line i ppf "Pcf_virt \"%s\" %a %a\n"
-        s.txt fmt_private_flag pf fmt_location loc;
+      line i ppf "Pcf_virt %a\n" fmt_private_flag pf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
       core_type (i+1) ppf ct;
   | Pcf_meth (s, pf, ovf, e) ->
-      line i ppf "Pcf_meth \"%s\" %a %a %a\n"
-        s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc;
+      line i ppf "Pcf_meth %a %a\n" fmt_private_flag pf fmt_override_flag ovf;
+      line (i+1) ppf "%a\n" fmt_string_loc s;
       expression (i+1) ppf e;
   | Pcf_constr (ct1, ct2) ->
-      line i ppf "Pcf_constr %a\n" fmt_location loc;
+      line i ppf "Pcf_constr\n";
       core_type (i+1) ppf ct1;
       core_type (i+1) ppf ct2;
   | Pcf_init (e) ->
@@ -503,7 +511,7 @@ and class_declaration i ppf x =
   line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
   line i ppf "pci_params =\n";
   string_list_x_location (i+1) ppf x.pci_params;
-  line i ppf "pci_name = \"%s\"\n" x.pci_name.txt;
+  line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name;
   line i ppf "pci_expr =\n";
   class_expr (i+1) ppf x.pci_expr;
 
@@ -511,12 +519,12 @@ and module_type i ppf x =
   line i ppf "module_type %a\n" fmt_location x.pmty_loc;
   let i = i+1 in
   match x.pmty_desc with
-  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident li;
+  | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li;
   | Pmty_signature (s) ->
       line i ppf "Pmty_signature\n";
       signature i ppf s;
   | Pmty_functor (s, mt1, mt2) ->
-      line i ppf "Pmty_functor \"%s\"\n" s.txt;
+      line i ppf "Pmty_functor %a\n" fmt_string_loc s;
       module_type i ppf mt1;
       module_type i ppf mt2;
   | Pmty_with (mt, l) ->
@@ -534,24 +542,27 @@ and signature_item i ppf x =
   let i = i+1 in
   match x.psig_desc with
   | Psig_value (s, vd) ->
-      line i ppf "Psig_value \"%s\"\n" s.txt;
+      line i ppf "Psig_value %a\n" fmt_string_loc s;
       value_description i ppf vd;
   | Psig_type (l) ->
       line i ppf "Psig_type\n";
       list i string_x_type_declaration ppf l;
   | Psig_exception (s, ed) ->
-      line i ppf "Psig_exception \"%s\"\n" s.txt;
+      line i ppf "Psig_exception %a\n" fmt_string_loc s;
       exception_declaration i ppf ed;
   | Psig_module (s, mt) ->
-      line i ppf "Psig_module \"%s\"\n" s.txt;
+      line i ppf "Psig_module %a\n" fmt_string_loc s;
       module_type i ppf mt;
   | Psig_recmodule decls ->
       line i ppf "Psig_recmodule\n";
       list i string_x_module_type ppf decls;
   | Psig_modtype (s, md) ->
-      line i ppf "Psig_modtype \"%s\"\n" s.txt;
+      line i ppf "Psig_modtype %a\n" fmt_string_loc s;
       modtype_declaration i ppf md;
-  | Psig_open li -> line i ppf "Psig_open %a\n" fmt_longident li;
+  | Psig_open (ovf, li) ->
+    line i ppf "Psig_open %a %a\n"
+      fmt_override_flag ovf
+      fmt_longident_loc li;
   | Psig_include (mt) ->
       line i ppf "Psig_include\n";
       module_type i ppf mt;
@@ -577,19 +588,19 @@ and with_constraint i ppf x =
   | Pwith_typesubst (td) ->
       line i ppf "Pwith_typesubst\n";
       type_declaration (i+1) ppf td;
-  | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident li;
-  | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
+  | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
+  | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
 
 and module_expr i ppf x =
   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
   let i = i+1 in
   match x.pmod_desc with
-  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li;
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li;
   | Pmod_structure (s) ->
       line i ppf "Pmod_structure\n";
       structure i ppf s;
   | Pmod_functor (s, mt, me) ->
-      line i ppf "Pmod_functor \"%s\"\n" s.txt;
+      line i ppf "Pmod_functor %a\n" fmt_string_loc s;
       module_type i ppf mt;
       module_expr i ppf me;
   | Pmod_apply (me1, me2) ->
@@ -617,26 +628,31 @@ and structure_item i ppf x =
       line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
       list i pattern_x_expression_def ppf l;
   | Pstr_primitive (s, vd) ->
-      line i ppf "Pstr_primitive \"%s\"\n" s.txt;
+      line i ppf "Pstr_primitive %a\n" fmt_string_loc s;
       value_description i ppf vd;
   | Pstr_type l ->
       line i ppf "Pstr_type\n";
       list i string_x_type_declaration ppf l;
   | Pstr_exception (s, ed) ->
-      line i ppf "Pstr_exception \"%s\"\n" s.txt;
+      line i ppf "Pstr_exception %a\n" fmt_string_loc s;
       exception_declaration i ppf ed;
   | Pstr_exn_rebind (s, li) ->
-      line i ppf "Pstr_exn_rebind \"%s\" %a\n" s.txt fmt_longident li;
+      line i ppf "Pstr_exn_rebind\n";
+      line (i+1) ppf "%a\n" fmt_string_loc s;
+      line (i+1) ppf "%a\n" fmt_longident_loc li;
   | Pstr_module (s, me) ->
-      line i ppf "Pstr_module \"%s\"\n" s.txt;
+      line i ppf "Pstr_module %a\n" fmt_string_loc s;
       module_expr i ppf me;
   | Pstr_recmodule bindings ->
       line i ppf "Pstr_recmodule\n";
       list i string_x_modtype_x_module ppf bindings;
   | Pstr_modtype (s, mt) ->
-      line i ppf "Pstr_modtype \"%s\"\n" s.txt;
+      line i ppf "Pstr_modtype %a\n" fmt_string_loc s;
       module_type i ppf mt;
-  | Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident li;
+  | Pstr_open (ovf, li) ->
+    line i ppf "Pstr_open %a %a\n"
+      fmt_override_flag ovf
+      fmt_longident_loc li;
   | Pstr_class (l) ->
       line i ppf "Pstr_class\n";
       list i class_declaration ppf l;
@@ -648,20 +664,20 @@ and structure_item i ppf x =
       module_expr i ppf me
 
 and string_x_type_declaration i ppf (s, td) =
-  string i ppf s.txt;
+  string_loc i ppf s;
   type_declaration (i+1) ppf td;
 
 and string_x_module_type i ppf (s, mty) =
-  string i ppf s.txt;
+  string_loc i ppf s;
   module_type (i+1) ppf mty;
 
 and string_x_modtype_x_module i ppf (s, mty, modl) =
-  string i ppf s.txt;
+  string_loc i ppf s;
   module_type (i+1) ppf mty;
   module_expr (i+1) ppf modl;
 
 and longident_x_with_constraint i ppf (li, wc) =
-  line i ppf "%a\n" fmt_longident li;
+  line i ppf "%a\n" fmt_longident_loc li;
   with_constraint (i+1) ppf wc;
 
 and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
@@ -670,12 +686,15 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
   core_type (i+1) ppf ct2;
 
 and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
-  line i ppf "\"%s\" %a\n" s.txt fmt_location loc;
+  line i ppf "%a\n" fmt_location loc;
+  line (i+1) ppf "%a\n" fmt_string_loc s;
   list (i+1) core_type ppf l;
   option (i+1) core_type ppf r_opt;
 
 and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
-  line i ppf "\"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc;
+  line i ppf "%a\n" fmt_location loc;
+  line (i+1) ppf "%a\n" fmt_mutable_flag mf;
+  line (i+1) ppf "%a" fmt_string_loc s;
   core_type (i+1) ppf ct;
 
 and string_list_x_location i ppf (l, loc) =
@@ -683,7 +702,7 @@ and string_list_x_location i ppf (l, loc) =
   list (i+1) string_loc ppf l;
 
 and longident_x_pattern i ppf (li, p) =
-  line i ppf "%a\n" fmt_longident li;
+  line i ppf "%a\n" fmt_longident_loc li;
   pattern (i+1) ppf p;
 
 and pattern_x_expression_case i ppf (p, e) =
@@ -697,11 +716,11 @@ and pattern_x_expression_def i ppf (p, e) =
   expression (i+1) ppf e;
 
 and string_x_expression i ppf (s, e) =
-  line i ppf " \"%s\"\n" s.txt;
+  line i ppf " %a\n" fmt_string_loc s;
   expression (i+1) ppf e;
 
 and longident_x_expression i ppf (li, e) =
-  line i ppf "%a\n" fmt_longident li;
+  line i ppf "%a\n" fmt_longident_loc li;
   expression (i+1) ppf e;
 
 and label_x_expression i ppf (l,e) =
@@ -732,7 +751,7 @@ and directive_argument i ppf x =
   | Pdir_none -> line i ppf "Pdir_none\n"
   | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
   | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
-  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident_noloc li;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
   | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
 ;;
 
diff --git a/parsing/printast.mli b/parsing/printast.mli
index ebffd0b7..a941da9e 100644
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printast.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Parsetree;;
 open Format;;
 
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index 9658dee2..5c17a99a 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -10,19 +10,19 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: syntaxerr.ml 12256 2012-03-23 02:16:44Z garrigue $ *)
-
 (* Auxiliary type for reporting syntax errors *)
 
 open Format
 
 type error =
     Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
   | Other of Location.t
 
 
+
 exception Error of error
 exception Escape_error
 
@@ -38,6 +38,10 @@ let report_error ppf = function
         fprintf ppf "%aThis '%s' might be unmatched"
           Location.print_error opening_loc opening
       end
+  | Expecting (loc, nonterm) ->
+      fprintf ppf
+        "%a@[Syntax error: %s expected.@]"
+        Location.print_error loc nonterm
   | Applicative_path loc ->
       fprintf ppf
         "%aSyntax error: applicative paths of the form F(X).t \
@@ -50,3 +54,11 @@ let report_error ppf = function
         Location.print_error loc var var
   | Other loc ->
       fprintf ppf "%aSyntax error" Location.print_error loc
+
+
+let location_of_error = function
+  | Unclosed(l,_,_,_)
+  | Applicative_path l
+  | Variable_in_scope(l,_)
+  | Other l
+  | Expecting (l, _) -> l
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index cef0b13c..03cf532e 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -10,14 +10,13 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: syntaxerr.mli 12256 2012-03-23 02:16:44Z garrigue $ *)
-
 (* Auxiliary type for reporting syntax errors *)
 
 open Format
 
 type error =
     Unclosed of Location.t * string * Location.t * string
+  | Expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
   | Other of Location.t
@@ -26,3 +25,5 @@ exception Error of error
 exception Escape_error
 
 val report_error: formatter -> error -> unit
+
+val location_of_error: error -> Location.t
diff --git a/stdlib/.depend b/stdlib/.depend
index b8a837db..326959e4 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -116,10 +116,10 @@ pervasives.cmo : pervasives.cmi
 pervasives.cmx : pervasives.cmi
 printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
 printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
-printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
-    array.cmi printf.cmi
-printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \
-    array.cmx printf.cmi
+printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \
+    printf.cmi
+printf.cmx : string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \
+    printf.cmi
 queue.cmo : obj.cmi queue.cmi
 queue.cmx : obj.cmx queue.cmi
 random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
@@ -226,10 +226,10 @@ pervasives.cmo : pervasives.cmi
 pervasives.p.cmx : pervasives.cmi
 printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
 printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
-printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
-    array.cmi printf.cmi
-printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \
-    array.p.cmx printf.cmi
+printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \
+    printf.cmi
+printf.p.cmx : string.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx array.p.cmx \
+    printf.cmi
 queue.cmo : obj.cmi queue.cmi
 queue.p.cmx : obj.p.cmx queue.cmi
 random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
diff --git a/stdlib/Compflags b/stdlib/Compflags
index b1270695..707487fd 100755
--- a/stdlib/Compflags
+++ b/stdlib/Compflags
@@ -12,12 +12,12 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Compflags 11240 2011-10-25 12:09:01Z weis $
-
 case $1 in
   pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
   camlinternalOO.cmi) echo ' -nopervasives';;
   camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  buffer.cmx|buffer.p.cmx) echo ' -inline 3';;
+                           # make sure add_char is inlined (PR#5872)
   buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
   scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
   arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
diff --git a/stdlib/Makefile b/stdlib/Makefile
index fb4d56f2..2796d2f1 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 include Makefile.shared
 
 allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING)
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index 1d9a666f..b85622b9 100644
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -11,8 +11,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 include Makefile.shared
 
 allopt: stdlib.cmxa std_exit.cmx
diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index f09532db..e9d5940a 100755
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -11,13 +11,11 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.shared 12383 2012-04-19 13:12:23Z xleroy $
-
 include ../config/Makefile
 RUNTIME=../boot/ocamlrun
 COMPILER=../ocamlc
 CAMLC=$(RUNTIME) $(COMPILER)
-COMPFLAGS=-strict-sequence -g -warn-error A -nostdlib
+COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -nostdlib
 OPTCOMPILER=../ocamlopt
 CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
 OPTCOMPFLAGS=-warn-error A -nostdlib -g
diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index efeeb8ba..c5c8896e 100644
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -13,8 +13,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: StdlibModules 11156 2011-07-27 14:17:02Z doligez $
-
 # This file lists all standard library modules.
 # It is used in particular to know what to expunge in toplevels.
 
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 797ad451..8b64236a 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arg.ml 11946 2011-12-23 13:34:13Z protzenk $ *)
-
 type key = string
 type doc = string
 type usage_msg = string
@@ -66,9 +64,10 @@ let make_symlist prefix sep suffix l =
 let print_spec buf (key, spec, doc) =
   if String.length doc > 0 then
     match spec with
-    | Symbol (l, _) -> bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l)
-                               doc
-    | _ -> bprintf buf "  %s %s\n" key doc
+    | Symbol (l, _) ->
+        bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l) doc
+    | _ ->
+        bprintf buf "  %s %s\n" key doc
 ;;
 
 let help_action () = raise (Stop (Unknown "-help"));;
@@ -103,7 +102,7 @@ let usage speclist errmsg =
 
 let current = ref 0;;
 
-let parse_argv ?(current=current) argv speclist anonfun errmsg =
+let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg =
   let l = Array.length argv in
   let b = Buffer.create 200 in
   let initpos = !current in
@@ -122,7 +121,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
       | Message s ->
           bprintf b "%s: %s.\n" progname s
     end;
-    usage_b b speclist errmsg;
+    usage_b b !speclist errmsg;
     if error = Unknown "-help" || error = Unknown "--help"
     then raise (Help (Buffer.contents b))
     else raise (Bad (Buffer.contents b))
@@ -132,7 +131,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
     let s = argv.(!current) in
     if String.length s >= 1 && String.get s 0 = '-' then begin
       let action =
-        try assoc3 s speclist
+        try assoc3 s !speclist
         with Not_found -> stop (Unknown s)
       in
       begin try
@@ -211,6 +210,10 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
   done;
 ;;
 
+let parse_argv ?(current=current) argv speclist anonfun errmsg =
+  parse_argv_dynamic ~current:current argv (ref speclist) anonfun errmsg;
+;;
+
 let parse l f msg =
   try
     parse_argv Sys.argv l f msg;
@@ -219,7 +222,15 @@ let parse l f msg =
   | Help msg -> printf "%s" msg; exit 0;
 ;;
 
-let rec second_word s =
+let parse_dynamic l f msg =
+  try
+    parse_argv_dynamic Sys.argv l f msg;
+  with
+  | Bad msg -> eprintf "%s" msg; exit 2;
+  | Help msg -> printf "%s" msg; exit 0;
+;;
+
+let second_word s =
   let len = String.length s in
   let rec loop n =
     if n >= len then len
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index 85dd8aae..869d030e 100644
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arg.mli 11939 2011-12-22 14:04:18Z protzenk $ *)
-
 (** Parsing of command line arguments.
 
    This module provides a general mechanism for extracting options and
@@ -95,6 +93,15 @@ val parse :
     by specifying your own [-help] and [--help] options in [speclist].
 *)
 
+val parse_dynamic :
+  (string * spec * string) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse}, except that the [speclist] argument is a reference
+    and may be updated during the parsing. A typical use for this feature
+    is to parse command lines of the form:
+-     command subcommand [options]
+    where the list of options depends on the value of the subcommand argument.
+*)
+
 val parse_argv : ?current: int ref -> string array ->
   (key * spec * doc) list -> anon_fun -> usage_msg -> unit
 (** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses
@@ -108,6 +115,13 @@ val parse_argv : ?current: int ref -> string array ->
   as argument.
 *)
 
+val parse_argv_dynamic : ?current:int ref -> string array ->
+  (string * spec * string) list ref -> anon_fun -> string -> unit
+(** Same as {!Arg.parse_argv}, except that the [speclist] argument is a
+    reference and may be updated during the parsing.
+    See {!Arg.parse_dynamic}.
+*)
+
 exception Help of string
 (** Raised by [Arg.parse_argv] when the user asks for help. *)
 
diff --git a/stdlib/array.ml b/stdlib/array.ml
index 78857a46..68c20331 100644
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: array.ml 12891 2012-08-28 15:07:45Z xleroy $ *)
-
 (* Array operations *)
 
 external length : 'a array -> int = "%array_length"
@@ -25,7 +23,8 @@ external create: int -> 'a -> 'a array = "caml_make_vect"
 external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
 external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
 external concat : 'a array list -> 'a array = "caml_array_concat"
-external unsafe_blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
+external unsafe_blit :
+  'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
 
 let init l f =
   if l = 0 then [||] else
@@ -152,7 +151,7 @@ let sort cmp a =
       set a i e;
     end;
   in
-  let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+  let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
   let rec bubbledown l i =
     let j = maxson l i in
     set a i (get a j);
diff --git a/stdlib/array.mli b/stdlib/array.mli
index 55463691..6913e2eb 100644
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: array.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Array operations. *)
 
 external length : 'a array -> int = "%array_length"
diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml
index e7b42e9c..39b4bde7 100644
--- a/stdlib/arrayLabels.ml
+++ b/stdlib/arrayLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arrayLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [ArrayLabels]: labelled Array module *)
 
 include Array
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index 41f0b5d3..03b6224a 100644
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arrayLabels.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Array operations. *)
 
 external length : 'a array -> int = "%array_length"
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index b2749acc..ffd6e5a4 100644
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: buffer.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Extensible buffers *)
 
 type t =
@@ -131,12 +129,7 @@ let advance_to_non_alpha s start =
   let rec advance i lim =
     if i >= lim then lim else
     match s.[i] with
-    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' |
-      'é'|'à'|'á'|'è'|'ù'|'â'|'ê'|
-      'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
-      'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|
-      'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
-      advance (i + 1) lim
+    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim
     | _ -> i in
   advance start (String.length s);;
 
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index 7d602c84..c50c9879 100644
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: buffer.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Extensible string buffers.
 
    This module implements string buffers that automatically expand
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
index e0af9d7c..34e7304f 100644
--- a/stdlib/callback.ml
+++ b/stdlib/callback.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: callback.ml 11922 2011-12-21 15:37:54Z doligez $ *)
-
 (* Registering OCaml values with the C runtime for later callbacks *)
 
 external register_named_value : string -> Obj.t -> unit
diff --git a/stdlib/callback.mli b/stdlib/callback.mli
index 5cf00bb3..de0d1837 100644
--- a/stdlib/callback.mli
+++ b/stdlib/callback.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: callback.mli 12147 2012-02-10 14:45:41Z doligez $ *)
-
 (** Registering OCaml values with the C runtime.
 
    This module allows OCaml values to be registered with the C runtime
diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
index 05aab527..dfdb19c7 100644
--- a/stdlib/camlinternalLazy.ml
+++ b/stdlib/camlinternalLazy.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalLazy.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Internals of forcing lazy values. *)
 
 exception Undefined;;
@@ -25,7 +23,8 @@ let force_lazy_block (blk : 'arg lazy_t) =
   Obj.set_field (Obj.repr blk) 0 raise_undefined;
   try
     let result = closure () in
-    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+    (* do set_field BEFORE set_tag *)
+    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
     Obj.set_tag (Obj.repr blk) Obj.forward_tag;
     result
   with e ->
@@ -38,7 +37,8 @@ let force_val_lazy_block (blk : 'arg lazy_t) =
   let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
   Obj.set_field (Obj.repr blk) 0 raise_undefined;
   let result = closure () in
-  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+  (* do set_field BEFORE set_tag *)
+  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);
   Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
   result
 ;;
diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
index fad5fcf6..27f87d14 100644
--- a/stdlib/camlinternalLazy.mli
+++ b/stdlib/camlinternalLazy.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalLazy.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Run-time support for lazy values.
     All functions in this module are for system use only, not for the
     casual user. *)
diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index 803acc2c..20a65207 100644
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalMod.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type shape =
   | Function
   | Lazy
diff --git a/stdlib/camlinternalMod.mli b/stdlib/camlinternalMod.mli
index bf1d5018..4ec4fde1 100644
--- a/stdlib/camlinternalMod.mli
+++ b/stdlib/camlinternalMod.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalMod.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Run-time support for recursive modules.
     All functions in this module are for system use only, not for the
     casual user. *)
diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 06af13d6..78e02fd4 100644
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalOO.ml 11930 2011-12-22 07:30:18Z garrigue $ *)
-
 open Obj
 
 (**** Object representation ****)
@@ -58,6 +56,7 @@ let initial_object_size = 2
 (**** Items ****)
 
 type item = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
 
 let dummy_item = (magic () : item)
 
@@ -67,6 +66,8 @@ type tag
 type label = int
 type closure = item
 type t = DummyA | DummyB | DummyC of int
+let _ = [DummyA; DummyB; DummyC 0] (* to avoid warnings *)
+
 type obj = t array
 external ret : (obj -> 'a) -> closure = "%identity"
 
@@ -86,12 +87,15 @@ let public_method_label s : tag =
 
 (**** Sparse array ****)
 
-module Vars = Map.Make(struct type t = string let compare = compare end)
+module Vars =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
 type vars = int Vars.t
 
-module Meths = Map.Make(struct type t = string let compare = compare end)
+module Meths =
+  Map.Make(struct type t = string let compare (x:t) y = compare x y end)
 type meths = label Meths.t
-module Labs = Map.Make(struct type t = label let compare = compare end)
+module Labs =
+  Map.Make(struct type t = label let compare (x:t) y = compare x y end)
 type labs = bool Labs.t
 
 (* The compiler assumes that the first field of this structure is [size]. *)
@@ -289,7 +293,8 @@ let add_initializer table f =
   table.initializers <- f::table.initializers
 
 (*
-module Keys = Map.Make(struct type t = tag array let compare = compare end)
+module Keys =
+  Map.Make(struct type t = tag array let compare (x:t) y = compare x y end)
 let key_map = ref Keys.empty
 let get_key tags : item =
   try magic (Keys.find tags !key_map : tag array)
diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index fc0f3fb3..afbe61bb 100644
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: camlinternalOO.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Run-time support for objects and classes.
     All functions in this module are for system use only, not for the
     casual user. *)
diff --git a/stdlib/char.ml b/stdlib/char.ml
index 61a55fae..15c46354 100644
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: char.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Character operations *)
 
 external code: char -> int = "%identity"
diff --git a/stdlib/char.mli b/stdlib/char.mli
index 160dcc79..d1baa64d 100644
--- a/stdlib/char.mli
+++ b/stdlib/char.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: char.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Character operations. *)
 
 external code : char -> int = "%identity"
diff --git a/stdlib/complex.ml b/stdlib/complex.ml
index ffb9794a..6d71d46a 100644
--- a/stdlib/complex.ml
+++ b/stdlib/complex.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: complex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Complex numbers *)
 
 type t = { re: float; im: float }
diff --git a/stdlib/complex.mli b/stdlib/complex.mli
index f57dc07f..645aa931 100644
--- a/stdlib/complex.mli
+++ b/stdlib/complex.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: complex.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Complex numbers.
 
     This module provides arithmetic operations on complex numbers.
diff --git a/stdlib/digest.ml b/stdlib/digest.ml
index 47e78de7..aee6cd26 100644
--- a/stdlib/digest.ml
+++ b/stdlib/digest.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: digest.ml 12082 2012-01-26 22:56:48Z doligez $ *)
-
 (* Message digest (MD5) *)
 
 type t = string
diff --git a/stdlib/digest.mli b/stdlib/digest.mli
index ca3de0f4..7fa1f15d 100644
--- a/stdlib/digest.mli
+++ b/stdlib/digest.mli
@@ -11,11 +11,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: digest.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
 (** MD5 message digest.
 
-   This module provides functions to compute 128-bit ``digests'' of
+   This module provides functions to compute 128-bit 'digests' of
    arbitrary-length strings or files. The digests are of cryptographic
    quality: it is very hard, given a digest, to forge a string having
    that digest. The algorithm used is MD5. This module should not be
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 156ceacb..db15169a 100644
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: filename.ml 12383 2012-04-19 13:12:23Z xleroy $ *)
-
 let generic_quote quotequote s =
   let l = String.length s in
   let b = Buffer.create (l + 20) in
@@ -132,7 +130,7 @@ module Win32 = struct
         | '\\' -> loop_bs (n+1) (i+1);
         | c    -> add_bs n; loop i
       end
-    and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done
+    and add_bs n = for _j = 1 to n do Buffer.add_char b '\\'; done
     in
     loop 0;
     Buffer.contents b
@@ -232,7 +230,8 @@ let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix =
       if counter >= 1000 then raise e else try_name (counter + 1)
   in try_name 0
 
-let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name) prefix suffix =
+let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name)
+                   prefix suffix =
   let rec try_name counter =
     let name = temp_file_name temp_dir prefix suffix in
     try
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index 1c6d6f13..c44c6d95 100644
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: filename.mli 12275 2012-03-26 17:18:30Z frisch $ *)
-
 (** Operations on file names. *)
 
 val current_dir_name : string
@@ -89,7 +87,8 @@ val temp_file : ?temp_dir: string -> string -> string -> string
 *)
 
 val open_temp_file :
-      ?mode: open_flag list -> ?temp_dir: string -> string -> string -> string * out_channel
+      ?mode: open_flag list -> ?temp_dir: string -> string -> string ->
+      string * out_channel
 (** Same as {!Filename.temp_file}, but returns both the name of a fresh
    temporary file, and an output channel opened (atomically) on
    this file.  This function is more secure than [temp_file]: there
diff --git a/stdlib/format.ml b/stdlib/format.ml
index 8087a0ed..fc2df512 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -11,9 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: format.ml 11243 2011-10-25 13:13:54Z weis $ *)
-
-(* A pretty-printing facility and definition of formatters for ``parallel''
+(* A pretty-printing facility and definition of formatters for 'parallel'
    (i.e. unrelated or independent) pretty-printing on multiple out channels. *)
 
 (**************************************************************
@@ -43,7 +41,7 @@ type pp_token =
 | Pp_newline                   (* to force a newline inside a block *)
 | Pp_if_newline                (* to do something only if this very
                                   line has been broken *)
-| Pp_open_tag of string        (* opening a tag name *)
+| Pp_open_tag of tag           (* opening a tag name *)
 | Pp_close_tag                 (* closing the most recently opened tag *)
 
 and tag = string
@@ -147,13 +145,13 @@ type formatter = {
   (* Ellipsis string. *)
   mutable pp_ellipsis : string;
   (* Output function. *)
-  mutable pp_output_function : string -> int -> int -> unit;
+  mutable pp_out_string : string -> int -> int -> unit;
   (* Flushing function. *)
-  mutable pp_flush_function : unit -> unit;
+  mutable pp_out_flush : unit -> unit;
   (* Output of new lines. *)
-  mutable pp_output_newline : unit -> unit;
+  mutable pp_out_newline : unit -> unit;
   (* Output of indentation spaces. *)
-  mutable pp_output_spaces : int -> unit;
+  mutable pp_out_spaces : int -> unit;
   (* Are tags printed ? *)
   mutable pp_print_tags : bool;
   (* Are tags marked ? *)
@@ -219,7 +217,7 @@ let pp_clear_queue state =
 (* Pp_infinity: large value for default tokens size.
 
    Pp_infinity is documented as being greater than 1e10; to avoid
-   confusion about the word ``greater'', we choose pp_infinity greater
+   confusion about the word 'greater', we choose pp_infinity greater
    than 1e10 + 1; for correct handling of tests in the algorithm,
    pp_infinity must be even one more than 1e10 + 1; let's stand on the
    safe side by choosing 1.e10+10.
@@ -240,9 +238,9 @@ let pp_clear_queue state =
 let pp_infinity = 1000000010;;
 
 (* Output functions for the formatter. *)
-let pp_output_string state s = state.pp_output_function s 0 (String.length s)
-and pp_output_newline state = state.pp_output_newline ()
-and pp_display_blanks state n = state.pp_output_spaces n
+let pp_output_string state s = state.pp_out_string s 0 (String.length s)
+and pp_output_newline state = state.pp_out_newline ()
+and pp_output_spaces state n = state.pp_out_spaces n
 ;;
 
 (* To format a break, indenting a new line. *)
@@ -254,7 +252,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_display_blanks state state.pp_current_indent
+  pp_output_spaces state state.pp_current_indent
 ;;
 
 (* To force a line break inside a block: no offset is added. *)
@@ -263,7 +261,7 @@ let break_line state width = break_new_line state 0 width;;
 (* To format a break that fits on the current line. *)
 let break_same_line state width =
   state.pp_space_left <- state.pp_space_left - width;
-  pp_display_blanks state width
+  pp_output_spaces state width
 ;;
 
 (* To indent no more than pp_max_indent, if one tries to open a block
@@ -675,9 +673,9 @@ and pp_open_box state indent = pp_open_box_gen state indent Pp_box;;
 (* Print a new line after printing all queued text
    (same for print_flush but without a newline). *)
 let pp_print_newline state () =
-  pp_flush_queue state true; state.pp_flush_function ()
+  pp_flush_queue state true; state.pp_out_flush ()
 and pp_print_flush state () =
-  pp_flush_queue state false; state.pp_flush_function ();;
+  pp_flush_queue state false; state.pp_out_flush ();;
 
 (* To get a newline when one does not want to close the current block. *)
 let pp_force_newline state () =
@@ -808,42 +806,70 @@ let pp_set_margin state n =
 
 let pp_get_margin state () = state.pp_margin;;
 
+type formatter_out_functions = {
+  out_string : string -> int -> int -> unit;
+  out_flush : unit -> unit;
+  out_newline : unit -> unit;
+  out_spaces : int -> unit;
+}
+;;
+
+let pp_set_formatter_out_functions state {
+      out_string = f;
+      out_flush = g;
+      out_newline = h;
+      out_spaces = i;
+    } =
+  state.pp_out_string <- f;
+  state.pp_out_flush <- g;
+  state.pp_out_newline <- h;
+  state.pp_out_spaces <- i;
+;;
+
+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;
+}
+;;
+
 let pp_set_formatter_output_functions state f g =
-  state.pp_output_function <- f; state.pp_flush_function <- g;;
+  state.pp_out_string <- f; state.pp_out_flush <- g;;
 let pp_get_formatter_output_functions state () =
-  (state.pp_output_function, state.pp_flush_function)
+  (state.pp_out_string, state.pp_out_flush)
 ;;
 
 let pp_set_all_formatter_output_functions state
     ~out:f ~flush:g ~newline:h ~spaces:i =
   pp_set_formatter_output_functions state f g;
-  state.pp_output_newline <- h;
-  state.pp_output_spaces <- i;
+  state.pp_out_newline <- h;
+  state.pp_out_spaces <- i;
 ;;
 let pp_get_all_formatter_output_functions state () =
-  (state.pp_output_function, state.pp_flush_function,
-   state.pp_output_newline, state.pp_output_spaces)
+  (state.pp_out_string, state.pp_out_flush,
+   state.pp_out_newline, state.pp_out_spaces)
 ;;
 
 (* Default function to output new lines. *)
-let display_newline state () = state.pp_output_function "\n" 0  1;;
+let display_newline state () = state.pp_out_string "\n" 0  1;;
 
 (* Default function to output spaces. *)
 let blank_line = String.make 80 ' ';;
 let rec display_blanks state n =
   if n > 0 then
-  if n <= 80 then state.pp_output_function blank_line 0 n else
+  if n <= 80 then state.pp_out_string blank_line 0 n else
   begin
-    state.pp_output_function blank_line 0 80;
+    state.pp_out_string blank_line 0 80;
     display_blanks state (n - 80)
   end
 ;;
 
 let pp_set_formatter_out_channel state os =
-  state.pp_output_function <- output os;
-  state.pp_flush_function <- (fun () -> flush os);
-  state.pp_output_newline <- display_newline state;
-  state.pp_output_spaces <- display_blanks state;
+  state.pp_out_string <- output os;
+  state.pp_out_flush <- (fun () -> flush os);
+  state.pp_out_newline <- display_newline state;
+  state.pp_out_spaces <- display_blanks state;
 ;;
 
 (**************************************************************
@@ -855,8 +881,8 @@ let pp_set_formatter_out_channel state os =
 let default_pp_mark_open_tag s = "<" ^ s ^ ">";;
 let default_pp_mark_close_tag s = "";;
 
-let default_pp_print_open_tag _ = ();;
-let default_pp_print_close_tag = default_pp_print_open_tag;;
+let default_pp_print_open_tag = ignore;;
+let default_pp_print_close_tag = ignore;;
 
 let pp_make_formatter f g h i =
   (* The initial state of the formatter contains a dummy box. *)
@@ -883,10 +909,10 @@ let pp_make_formatter f g h i =
    pp_curr_depth = 1;
    pp_max_boxes = max_int;
    pp_ellipsis = ".";
-   pp_output_function = f;
-   pp_flush_function = g;
-   pp_output_newline = h;
-   pp_output_spaces = i;
+   pp_out_string = f;
+   pp_out_flush = g;
+   pp_out_newline = h;
+   pp_out_spaces = i;
    pp_print_tags = false;
    pp_mark_tags = false;
    pp_mark_open_tag = default_pp_mark_open_tag;
@@ -900,8 +926,8 @@ let pp_make_formatter f g h i =
 (* Make a formatter with default functions to output spaces and new lines. *)
 let make_formatter output flush =
   let ppf = pp_make_formatter output flush ignore ignore in
-  ppf.pp_output_newline <- display_newline ppf;
-  ppf.pp_output_spaces <- display_blanks ppf;
+  ppf.pp_out_newline <- display_newline ppf;
+  ppf.pp_out_spaces <- display_blanks ppf;
   ppf
 ;;
 
@@ -979,6 +1005,11 @@ and get_ellipsis_text = pp_get_ellipsis_text std_formatter
 and set_formatter_out_channel =
   pp_set_formatter_out_channel std_formatter
 
+and set_formatter_out_functions =
+  pp_set_formatter_out_functions std_formatter
+and get_formatter_out_functions =
+  pp_get_formatter_out_functions std_formatter
+
 and set_formatter_output_functions =
   pp_set_formatter_output_functions std_formatter
 and get_formatter_output_functions =
@@ -1020,7 +1051,7 @@ module Tformat = Printf.CamlinternalPr.Tformat;;
 (* Trailer: giving up at character number ... *)
 let giving_up mess fmt i =
   Printf.sprintf
-    "Format.fprintf: %s ``%s'', giving up at character number %d%s"
+    "Format.fprintf: %s \'%s\', giving up at character number %d%s"
     mess (Sformat.to_string fmt) i
     (if i < Sformat.length fmt
      then Printf.sprintf " (%c)." (Sformat.get fmt i)
@@ -1085,225 +1116,228 @@ let implode_rev s0 = function
    according to the format string.
    Regular [fprintf]-like functions of this module are obtained via partial
    applications of [mkprintf]. *)
-let mkprintf to_s get_out =
-
-  let rec kprintf k fmt =
+let mkprintf to_s get_out k fmt =
+
+  (* [out] is global to this definition of [pr], and must be shared by all its
+     recursive calls (if any). *)
+  let out = get_out fmt in
+  let print_as = ref None in
+  let outc c =
+    match !print_as with
+    | None -> pp_print_char out c
+    | Some size ->
+      pp_print_as_size out size (String.make 1 c);
+      print_as := None
+  and outs s =
+    match !print_as with
+    | None -> pp_print_string out s
+    | Some size ->
+      pp_print_as_size out size s;
+      print_as := None
+  and flush out = pp_print_flush out () in
+
+  let rec pr k n fmt v =
 
     let len = Sformat.length fmt in
 
-    let kpr fmt v =
-      let ppf = get_out fmt in
-      let print_as = ref None in
-      let pp_print_as_char c =
-        match !print_as with
-        | None -> pp_print_char ppf c
-        | Some size ->
-          pp_print_as_size ppf size (String.make 1 c);
-          print_as := None
-      and pp_print_as_string s =
-        match !print_as with
-        | None -> pp_print_string ppf s
-        | Some size ->
-          pp_print_as_size ppf size s;
-          print_as := None in
-
-      let rec doprn n i =
-        if i >= len then Obj.magic (k ppf) else
-        match Sformat.get fmt i with
-        | '%' ->
-          Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+    let rec doprn n i =
+      if i >= len then Obj.magic (k out) else
+      match Sformat.get fmt i with
+      | '%' ->
+        Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+      | '@' ->
+        let i = succ i in
+        if i >= len then invalid_format fmt i else
+        begin match Sformat.get fmt i with
+        | '[' ->
+          do_pp_open_box out n (succ i)
+        | ']' ->
+          pp_close_box out ();
+          doprn n (succ i)
+        | '{' ->
+          do_pp_open_tag out n (succ i)
+        | '}' ->
+          pp_close_tag out ();
+          doprn n (succ i)
+        | ' ' ->
+          pp_print_space out ();
+          doprn n (succ i)
+        | ',' ->
+          pp_print_cut out ();
+          doprn n (succ i)
+        | '?' ->
+          pp_print_flush out ();
+          doprn n (succ i)
+        | '.' ->
+          pp_print_newline out ();
+          doprn n (succ i)
+        | '\n' ->
+          pp_force_newline out ();
+          doprn n (succ i)
+        | ';' ->
+          do_pp_break out n (succ i)
+        | '<' ->
+          let got_size size n i =
+            print_as := Some size;
+            doprn n (skip_gt i) in
+          get_int n (succ i) got_size
         | '@' ->
-          let i = succ i in
-          if i >= len then invalid_format fmt i else
-          begin match Sformat.get fmt i with
-          | '[' ->
-            do_pp_open_box ppf n (succ i)
-          | ']' ->
-            pp_close_box ppf ();
-            doprn n (succ i)
-          | '{' ->
-            do_pp_open_tag ppf n (succ i)
-          | '}' ->
-            pp_close_tag ppf ();
-            doprn n (succ i)
-          | ' ' ->
-            pp_print_space ppf ();
-            doprn n (succ i)
-          | ',' ->
-            pp_print_cut ppf ();
-            doprn n (succ i)
-          | '?' ->
-            pp_print_flush ppf ();
-            doprn n (succ i)
-          | '.' ->
-            pp_print_newline ppf ();
-            doprn n (succ i)
-          | '\n' ->
-            pp_force_newline ppf ();
-            doprn n (succ i)
-          | ';' ->
-            do_pp_break ppf n (succ i)
-          | '<' ->
-            let got_size size n i =
-              print_as := Some size;
-              doprn n (skip_gt i) in
-            get_int n (succ i) got_size
-          | '@' | '%' as c ->
-            pp_print_as_char c;
-            doprn n (succ i)
-          | _ -> invalid_format fmt i
-          end
-        | c ->
-          pp_print_as_char c;
+          outc '@';
           doprn n (succ i)
-
-      and cont_s n s i =
-        pp_print_as_string s; doprn n i
-      and cont_a n printer arg i =
-        if to_s then
-          pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg)
-        else
-          printer ppf arg;
-        doprn n i
-      and cont_t n printer i =
-        if to_s then
-          pp_print_as_string ((Obj.magic printer : unit -> string) ())
-        else
-          printer ppf;
-        doprn n i
-      and cont_f n i =
-        pp_print_flush ppf (); doprn n i
-      and cont_m n sfmt i =
-        kprintf (Obj.magic (fun _ -> doprn n i)) sfmt
-
-      and get_int n i c =
-        if i >= len then invalid_integer fmt i else
-        match Sformat.get fmt i with
-        | ' ' -> get_int n (succ i) c
-        | '%' ->
-          let cont_s n s i = c (format_int_of_string fmt i s) n i
-          and cont_a _n _printer _arg i = invalid_integer fmt i
-          and cont_t _n _printer i = invalid_integer fmt i
-          and cont_f _n i = invalid_integer fmt i
-          and cont_m _n _sfmt i = invalid_integer fmt i in
-          Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
-        | _ ->
-          let rec get j =
-            if j >= len then invalid_integer fmt j else
-            match Sformat.get fmt j with
-            | '0' .. '9' | '-' -> get (succ j)
-            | _ ->
-              let size =
-                if j = i then size_of_int 0 else
-                let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
-                format_int_of_string fmt j s in
-              c size n j in
-          get i
-
-      and skip_gt i =
-        if i >= len then invalid_format fmt i else
-        match Sformat.get fmt i with
-        | ' ' -> skip_gt (succ i)
-        | '>' -> succ i
         | _ -> invalid_format fmt i
-
-      and get_box_kind i =
-        if i >= len then Pp_box, i else
-        match Sformat.get fmt i with
-        | 'h' ->
+        end
+      | c -> outc c; doprn n (succ i)
+
+    and cont_s n s i =
+      outs s; doprn n i
+    and cont_a n printer arg i =
+      if to_s then
+        outs ((Obj.magic printer : unit -> _ -> string) () arg)
+      else
+        printer out arg;
+      doprn n i
+    and cont_t n printer i =
+      if to_s then
+        outs ((Obj.magic printer : unit -> string) ())
+      else
+        printer out;
+      doprn n i
+    and cont_f n i =
+      flush out; doprn n i
+    and cont_m n xf i =
+      let m =
+        Sformat.add_int_index
+          (Tformat.count_printing_arguments_of_format xf) n in
+      pr (Obj.magic (fun _ -> doprn m i)) n xf v
+
+    and get_int n i c =
+      if i >= len then invalid_integer fmt i else
+      match Sformat.get fmt i with
+      | ' ' -> get_int n (succ i) c
+      | '%' ->
+        let cont_s n s i = c (format_int_of_string fmt i s) n i
+        and cont_a _n _printer _arg i = invalid_integer fmt i
+        and cont_t _n _printer i = invalid_integer fmt i
+        and cont_f _n i = invalid_integer fmt i
+        and cont_m _n _sfmt i = invalid_integer fmt i in
+        Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+      | _ ->
+        let rec get j =
+          if j >= len then invalid_integer fmt j else
+          match Sformat.get fmt j with
+          | '0' .. '9' | '-' -> get (succ j)
+          | _ ->
+            let size =
+              if j = i then size_of_int 0 else
+              let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
+              format_int_of_string fmt j s in
+            c size n j in
+        get i
+
+    and skip_gt i =
+      if i >= len then invalid_format fmt i else
+      match Sformat.get fmt i with
+      | ' ' -> skip_gt (succ i)
+      | '>' -> succ i
+      | _ -> invalid_format fmt i
+
+    and get_box_kind i =
+      if i >= len then Pp_box, i else
+      match Sformat.get fmt i with
+      | 'h' ->
+         let i = succ i in
+         if i >= len then Pp_hbox, i else
+         begin match Sformat.get fmt i with
+         | 'o' ->
            let i = succ i in
-           if i >= len then Pp_hbox, i else
+           if i >= len then format_invalid_arg "bad box format" fmt i else
            begin match Sformat.get fmt i with
-           | 'o' ->
-             let i = succ i in
-             if i >= len then format_invalid_arg "bad box format" fmt i else
-             begin match Sformat.get fmt i with
-             | 'v' -> Pp_hovbox, succ i
-             | c ->
-               format_invalid_arg
-                 ("bad box name ho" ^ String.make 1 c) fmt i
-             end
-           | 'v' -> Pp_hvbox, succ i
-           | _ -> Pp_hbox, i
+           | 'v' -> Pp_hovbox, succ i
+           | c ->
+             format_invalid_arg
+               ("bad box name ho" ^ String.make 1 c) fmt i
            end
-        | 'b' -> Pp_box, succ i
-        | 'v' -> Pp_vbox, succ i
-        | _ -> Pp_box, i
-
-      and get_tag_name n i c =
-        let rec get accu n i j =
-          if j >= len then
-            c (implode_rev
-                 (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-                 accu)
-              n j else
-          match Sformat.get fmt j with
-          | '>' ->
-            c (implode_rev
-                 (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-                 accu)
-              n j
-          | '%' ->
-            let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
-            let cont_s n s i = get (s :: s0 :: accu) n i i
-            and cont_a n printer arg i =
-              let s =
-                if to_s
-                then (Obj.magic printer : unit -> _ -> string) () arg
-                else exstring printer arg in
-              get (s :: s0 :: accu) n i i
-            and cont_t n printer i =
-              let s =
-                if to_s
-                then (Obj.magic printer : unit -> string) ()
-                else exstring (fun ppf () -> printer ppf) () in
-              get (s :: s0 :: accu) n i i
-            and cont_f _n i =
-              format_invalid_arg "bad tag name specification" fmt i
-            and cont_m _n _sfmt i =
-              format_invalid_arg "bad tag name specification" fmt i in
-            Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
-          | _ -> get accu n i (succ j) in
-        get [] n i i
-
-      and do_pp_break ppf n i =
-        if i >= len then begin pp_print_space ppf (); doprn n i end else
-        match Sformat.get fmt i with
-        | '<' ->
-          let rec got_nspaces nspaces n i =
-            get_int n i (got_offset nspaces)
-          and got_offset nspaces offset n i =
-            pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
-            doprn n (skip_gt i) in
-          get_int n (succ i) got_nspaces
-        | _c -> pp_print_space ppf (); doprn n i
-
-      and do_pp_open_box ppf n i =
-        if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
-        match Sformat.get fmt i with
-        | '<' ->
-          let kind, i = get_box_kind (succ i) in
-          let got_size size n i =
-            pp_open_box_gen ppf (int_of_size size) kind;
-            doprn n (skip_gt i) in
-          get_int n i got_size
-        | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
-
-      and do_pp_open_tag ppf n i =
-        if i >= len then begin pp_open_tag ppf ""; doprn n i end else
-        match Sformat.get fmt i with
-        | '<' ->
-          let got_name tag_name n i =
-            pp_open_tag ppf tag_name;
-            doprn n (skip_gt i) in
-          get_tag_name n (succ i) got_name
-        | _c -> pp_open_tag ppf ""; doprn n i in
-
-      doprn (Sformat.index_of_int 0) 0 in
-
-    Tformat.kapr kpr fmt in
-
-  kprintf
+         | 'v' -> Pp_hvbox, succ i
+         | _ -> Pp_hbox, i
+         end
+      | 'b' -> Pp_box, succ i
+      | 'v' -> Pp_vbox, succ i
+      | _ -> Pp_box, i
+
+    and get_tag_name n i c =
+      let rec get accu n i j =
+        if j >= len then
+          c (implode_rev
+               (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+               accu)
+            n j else
+        match Sformat.get fmt j with
+        | '>' ->
+          c (implode_rev
+               (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+               accu)
+            n j
+        | '%' ->
+          let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
+          let cont_s n s i = get (s :: s0 :: accu) n i i
+          and cont_a n printer arg i =
+            let s =
+              if to_s
+              then (Obj.magic printer : unit -> _ -> string) () arg
+              else exstring printer arg in
+            get (s :: s0 :: accu) n i i
+          and cont_t n printer i =
+            let s =
+              if to_s
+              then (Obj.magic printer : unit -> string) ()
+              else exstring (fun ppf () -> printer ppf) () in
+            get (s :: s0 :: accu) n i i
+          and cont_f _n i =
+            format_invalid_arg "bad tag name specification" fmt i
+          and cont_m _n _sfmt i =
+            format_invalid_arg "bad tag name specification" fmt i in
+          Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
+        | _ -> get accu n i (succ j) in
+      get [] n i i
+
+    and do_pp_break ppf n i =
+      if i >= len then begin pp_print_space ppf (); doprn n i end else
+      match Sformat.get fmt i with
+      | '<' ->
+        let rec got_nspaces nspaces n i =
+          get_int n i (got_offset nspaces)
+        and got_offset nspaces offset n i =
+          pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
+          doprn n (skip_gt i) in
+        get_int n (succ i) got_nspaces
+      | _c -> pp_print_space ppf (); doprn n i
+
+    and do_pp_open_box ppf n i =
+      if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
+      match Sformat.get fmt i with
+      | '<' ->
+        let kind, i = get_box_kind (succ i) in
+        let got_size size n i =
+          pp_open_box_gen ppf (int_of_size size) kind;
+          doprn n (skip_gt i) in
+        get_int n i got_size
+      | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
+
+    and do_pp_open_tag ppf n i =
+      if i >= len then begin pp_open_tag ppf ""; doprn n i end else
+      match Sformat.get fmt i with
+      | '<' ->
+        let got_name tag_name n i =
+          pp_open_tag ppf tag_name;
+          doprn n (skip_gt i) in
+        get_tag_name n (succ i) got_name
+      | _c -> pp_open_tag ppf ""; doprn n i in
+
+    doprn n 0 in
+
+  let kpr = pr k (Sformat.index_of_int 0) in
+
+  Tformat.kapr kpr fmt
 ;;
 
 (**************************************************************
@@ -1323,11 +1357,20 @@ let eprintf fmt = fprintf err_formatter fmt;;
 let ksprintf k =
   let b = Buffer.create 512 in
   let k ppf = k (string_out b ppf) in
-  mkprintf true (fun _ -> formatter_of_buffer b) k
+  let ppf = formatter_of_buffer b in
+  let get_out _ = ppf in
+  mkprintf true get_out k
 ;;
 
 let sprintf fmt = ksprintf (fun s -> s) fmt;;
 
+let asprintf fmt =
+  let b = Buffer.create 512 in
+  let k ppf = string_out b ppf in
+  let ppf = formatter_of_buffer b in
+  let get_out _ = ppf in
+  mkprintf false get_out k fmt;;
+
 (**************************************************************
 
   Deprecated stuff.
@@ -1347,5 +1390,6 @@ let bprintf b =
 (* Deprecated alias for ksprintf. *)
 let kprintf = ksprintf;;
 
+(* Output everything left in the pretty printer queue at end of execution. *)
 at_exit print_flush
 ;;
diff --git a/stdlib/format.mli b/stdlib/format.mli
index 6dc86940..2df4779c 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -11,12 +11,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: format.mli 12906 2012-09-08 15:27:53Z doligez $ *)
-
 (** Pretty printing.
 
    This module implements a pretty-printing facility to format text
-   within ``pretty-printing boxes''. The pretty-printer breaks lines
+   within 'pretty-printing boxes'. The pretty-printer breaks lines
    at specified break hints, and indents lines according to the box
    structure.
 
@@ -80,7 +78,7 @@ val open_box : int -> unit;;
 (** [open_box d] opens a new pretty-printing box
    with offset [d].
    This box is the general purpose pretty-printing box.
-   Material in this box is displayed ``horizontal or vertical'':
+   Material in this box is displayed 'horizontal or vertical':
    break hints inside the box may lead to a new line, if there
    is no more room on the line to print the remainder of the box,
    or if a new line may lead to a new indentation
@@ -186,11 +184,10 @@ val get_max_indent : unit -> int;;
 (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
 
 val set_max_boxes : int -> unit;;
-(** [set_max_boxes max] sets the maximum number
-   of boxes simultaneously opened.
-   Material inside boxes nested deeper is printed as an
-   ellipsis (more precisely as the text returned by
-   [get_ellipsis_text ()]).
+(** [set_max_boxes max] sets the maximum number of boxes simultaneously
+   opened.
+   Material inside boxes nested deeper is printed as an ellipsis (more
+   precisely as the text returned by [get_ellipsis_text ()]).
    Nothing happens if [max] is smaller than 2. *)
 
 val get_max_boxes : unit -> int;;
@@ -203,13 +200,13 @@ val over_max_boxes : unit -> bool;;
 
 val open_hbox : unit -> unit;;
 (** [open_hbox ()] opens a new pretty-printing box.
-   This box is ``horizontal'': the line is not split in this box
+   This box is 'horizontal': the line is not split in this box
    (new lines may still occur inside boxes nested deeper). *)
 
 val open_vbox : int -> unit;;
 (** [open_vbox d] opens a new pretty-printing box
    with offset [d].
-   This box is ``vertical'': every break hint inside this
+   This box is 'vertical': every break hint inside this
    box leads to a new line.
    When a new line is printed in the box, [d] is added to the
    current indentation. *)
@@ -217,16 +214,16 @@ val open_vbox : int -> unit;;
 val open_hvbox : int -> unit;;
 (** [open_hvbox d] opens a new pretty-printing box
    with offset [d].
-   This box is ``horizontal-vertical'': it behaves as an
-   ``horizontal'' box if it fits on a single line,
-   otherwise it behaves as a ``vertical'' box.
+   This box is 'horizontal-vertical': it behaves as an
+   'horizontal' box if it fits on a single line,
+   otherwise it behaves as a 'vertical' box.
    When a new line is printed in the box, [d] is added to the
    current indentation. *)
 
 val open_hovbox : int -> unit;;
 (** [open_hovbox d] opens a new pretty-printing box
    with offset [d].
-   This box is ``horizontal or vertical'': break hints
+   This box is 'horizontal or vertical': break hints
    inside this box may lead to a new line, if there is no more room
    on the line to print the remainder of the box.
    When a new line is printed in the box, [d] is added to the
@@ -277,13 +274,13 @@ type tag = string;;
    entities (e.g. HTML or TeX elements or terminal escape sequences).
 
    By default, those tags do not influence line breaking calculation:
-   the tag ``markers'' are not considered as part of the printing
+   the tag 'markers' are not considered as part of the printing
    material that drives line breaking (in other words, the length of
    those strings is considered as zero for line breaking).
 
    Thus, tag handling is in some sense transparent to pretty-printing
-   and does not interfere with usual pretty-printing. Hence, a single
-   pretty printing routine can output both simple ``verbatim''
+   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],
@@ -291,14 +288,14 @@ type tag = string;;
    accordingly.
 
    When a tag has been opened (or closed), it is both and successively
-   ``printed'' and ``marked''. Printing a tag means calling a
+   '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
+   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-breaking computation). Marking a
-   tag means to output an arbitrary string (the ``tag marker''),
+   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
+   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
@@ -323,6 +320,7 @@ val open_tag : tag -> unit;;
    function of the formatter is called with [t] as argument;
    the tag marker [mark_open_tag t] will be flushed into the output
    device of the formatter. *)
+
 val close_tag : unit -> unit;;
 (** [close_tag ()] closes the most recently opened tag [t].
    In addition, the [print_close_tag] function of the formatter is called
@@ -350,15 +348,17 @@ val set_formatter_output_functions :
   (string -> int -> int -> unit) -> (unit -> unit) -> unit
 ;;
 (** [set_formatter_output_functions out flush] redirects the
-   relevant pretty-printer output functions to the functions [out] and
+   pretty-printer output functions to the functions [out] and
    [flush].
 
-   The [out] function performs 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 [flush] function is called whenever the pretty-printer is
-   flushed (via conversion [%!], pretty-printing indications [@?] or [@.],
-   or using low level function [print_flush] or [print_newline]). *)
+   The [out] 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 [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]). *)
 
 val get_formatter_output_functions :
   unit -> (string -> int -> int -> unit) * (unit -> unit)
@@ -372,35 +372,32 @@ val get_formatter_output_functions :
  how to handle indentation, line breaking, and even printing of all the
  characters that have to be printed! *)
 
-val set_all_formatter_output_functions :
-  out:(string -> int -> int -> unit) ->
-  flush:(unit -> unit) ->
-  newline:(unit -> unit) ->
-  spaces:(int -> unit) ->
-  unit
+type formatter_out_functions = {
+  out_string : string -> int -> int -> unit;
+  out_flush : unit -> unit;
+  out_newline : unit -> unit;
+  out_spaces : int -> unit;
+}
 ;;
-(** [set_all_formatter_output_functions out flush outnewline outspace]
-   redirects the pretty-printer output to the functions [out] and
-   [flush] as described in [set_formatter_output_functions]. In
-   addition, the pretty-printer function that outputs a newline is set
-   to the function [outnewline] and the function that outputs
-   indentation spaces is set to the function [outspace].
 
-   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
-   [outspace] and [outnewline] are normally connected to [out] and
-   [flush]: respective default values for [outspace] and [outnewline]
-   are [out (String.make n ' ') 0 n] and [out "\n" 0 1]. *)
+val set_formatter_out_functions : formatter_out_functions -> unit;;
+(** [set_formatter_out_functions out_funs]
+   Redirect the pretty-printer output to the functions [out_funs.out_string]
+   and [out_funs.out_flush] as described in
+   [set_formatter_output_functions]. In addition, the pretty-printer function
+   that outputs a newline is set to the function [out_funs.out_newline] and
+   the function that outputs indentation spaces is set to the function
+   [out_funs.out_spaces].
 
-val get_all_formatter_output_functions :
-  unit ->
-  (string -> int -> int -> unit) *
-  (unit -> unit) *
-  (unit -> unit) *
-  (int -> unit)
-;;
+   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 [out_spaces] and [out_newline] are
+   normally connected to [out_string] and [out_flush]: respective default
+   values for [out_space] and [out_newline] are
+   [out_string (String.make n ' ') 0 n] and [out_string "\n" 0 1]. *)
+
+val get_formatter_out_functions : unit -> formatter_out_functions;;
 (** Return the current output functions of the pretty-printer,
    including line breaking and indentation functions. Useful to record the
    current setting and restore it afterwards. *)
@@ -415,16 +412,13 @@ type formatter_tag_functions = {
 }
 ;;
 (** The tag handling functions specific to a formatter:
-   [mark] versions are the ``tag marking'' functions that associate a string
+   [mark] versions are the 'tag marking' functions that associate a string
    marker to a tag in order for the pretty-printing engine to flush
    those markers as 0 length tokens in the output device of the formatter.
-   [print] versions are the ``tag printing'' functions that can perform
+   [print] versions are the 'tag printing' functions that can perform
    regular printing when a tag is closed or opened. *)
 
-val set_formatter_tag_functions :
-  formatter_tag_functions -> unit
-;;
-
+val set_formatter_tag_functions : formatter_tag_functions -> unit;;
 (** [set_formatter_tag_functions tag_funs] changes the meaning of
    opening and closing tags to use the functions in [tag_funs].
 
@@ -440,9 +434,7 @@ val set_formatter_tag_functions :
    called at tag opening and tag closing time, to output regular
    material in the pretty-printer queue. *)
 
-val get_formatter_tag_functions :
-  unit -> formatter_tag_functions
-;;
+val get_formatter_tag_functions : unit -> formatter_tag_functions;;
 (** Return the current tag functions of the pretty-printer. *)
 
 (** {6 Multiple formatted output} *)
@@ -546,28 +538,27 @@ val pp_get_max_boxes : formatter -> unit -> int;;
 val pp_over_max_boxes : formatter -> unit -> bool;;
 val pp_set_ellipsis_text : formatter -> string -> unit;;
 val pp_get_ellipsis_text : formatter -> unit -> string;;
-val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit;;
+val pp_set_formatter_out_channel :
+  formatter -> Pervasives.out_channel -> unit
+;;
 val pp_set_formatter_output_functions :
   formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
 ;;
 val pp_get_formatter_output_functions :
   formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
 ;;
-val pp_set_all_formatter_output_functions :
-  formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
-  newline:(unit -> unit) -> spaces:(int -> unit) -> unit
-;;
-val pp_get_all_formatter_output_functions :
-  formatter -> unit ->
-  (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
-  (int -> unit)
-;;
 val pp_set_formatter_tag_functions :
   formatter -> formatter_tag_functions -> unit
 ;;
 val pp_get_formatter_tag_functions :
   formatter -> unit -> formatter_tag_functions
 ;;
+val pp_set_formatter_out_functions :
+  formatter -> formatter_out_functions -> unit
+;;
+val pp_get_formatter_out_functions :
+  formatter -> unit -> formatter_out_functions
+;;
 (** These functions are the basic ones: usual functions
    operating on the standard formatter are defined via partial
    evaluation of these primitives. For instance,
@@ -594,27 +585,24 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
      then an optional integer offset, and the closing [>] character.
      Box type is one of [h], [v], [hv], [b], or [hov],
      which stand respectively for an horizontal box, a vertical box,
-     an ``horizontal-vertical'' box, or an ``horizontal or
-     vertical'' box ([b] standing for an ``horizontal or
-     vertical'' box demonstrating indentation and [hov] standing
-     for a regular``horizontal or vertical'' box).
-     For instance, [@\[] opens an ``horizontal or vertical''
+     an 'horizontal-vertical' box, or an 'horizontal or
+     vertical' box ([b] standing for an 'horizontal or
+     vertical' box demonstrating indentation and [hov] standing
+     for a regular'horizontal or vertical' box).
+     For instance, [@\[] 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
      functions [open_*box].
    - [@\]]: close the most recently opened pretty-printing box.
-   - [@,]: output a good break as with [print_cut ()].
-   - [@ ]: output a space, as with [print_space ()].
-   - [@\n]: force a newline, as with [force_newline ()].
-   - [@;]: output a good break as with [print_break]. The
+   - [@,]: output a good break hint, as with [print_cut ()].
+   - [@ ]: output a good break space, as with [print_space ()].
+   - [@;]: output a fully specified good break as with [print_break]. The
      [nspaces] and [offset] parameters of the break may be
      optionally specified with the following syntax:
      the [<] character, followed by an integer [nspaces] value,
      then an integer [offset], and a closing [>] character.
      If no parameters are provided, the good break defaults to a
-     space.
-   - [@?]: flush the pretty printer as with [print_flush ()].
-     This is equivalent to the conversion [%!].
+     good break space.
    - [@.]: flush the pretty printer and output a new line, as with
      [print_newline ()].
    - [@]: print the following item as if it were of length [n].
@@ -632,17 +620,20 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
      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 ()].
+     This is equivalent to the conversion [%!].
+   - [@\n]: force a newline, as with [force_newline ()].
+   - [@@]: print a single [@] character.
 
    Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
    [open_box (); print_string "x ="; print_space ();
     print_int 1; close_box (); print_newline ()].
    It prints [x = 1] within a pretty-printing box.
 
-   Note: the old [@@] ``pretty-printing indication'' is now deprecated, since
-   it had no pretty-printing indication semantics. If you need to prevent
-   the pretty-printing indication interpretation of a [@] character, simply
-   use the regular way to escape a character in format string: write [%@].
-   @since 3.12.2.
+   Note: If you need to prevent the interpretation of a [@] character as a
+   pretty-printing indication, escape it with a [%] character, as usual in
+   format strings.
+   @since 3.12.2
 
 *)
 
@@ -665,7 +656,16 @@ val sprintf : ('a, unit, string) format -> 'a;;
 
    Alternatively, you can use [Format.fprintf] with a formatter writing to a
    buffer of your own: flushing the formatter and the buffer at the end of
-   pretty-printing returns the desired string. *)
+   pretty-printing returns the desired string.
+*)
+
+val asprintf : ('a, formatter, unit, string) format4 -> 'a;;
+(** Same as [printf] above, but instead of printing on a formatter,
+   returns a string containing the result of formatting the arguments.
+   The type of [asprintf] is general enough to interact nicely with [%a]
+   conversions.
+   @since 4.01.0
+ *)
 
 val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;;
 (** Same as [fprintf] above, but does not print anything.
@@ -704,3 +704,41 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;;
 
 val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 (** A deprecated synonym for [ksprintf]. *)
+
+val set_all_formatter_output_functions :
+  out:(string -> int -> int -> unit) ->
+  flush:(unit -> unit) ->
+  newline:(unit -> unit) ->
+  spaces:(int -> unit) ->
+  unit
+;;
+(** Deprecated. Subsumed by [set_formatter_out_functions].
+  @since 4.00.0
+*)
+
+val get_all_formatter_output_functions :
+  unit ->
+  (string -> int -> int -> unit) *
+  (unit -> unit) *
+  (unit -> unit) *
+  (int -> unit)
+;;
+(** Deprecated. Subsumed by [get_formatter_out_functions].
+  @since 4.00.0
+*)
+val pp_set_all_formatter_output_functions :
+  formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
+  newline:(unit -> unit) -> spaces:(int -> unit) -> unit
+;;
+(** Deprecated. Subsumed by [pp_set_formatter_out_functions].
+  @since 4.01.0
+*)
+
+val pp_get_all_formatter_output_functions :
+  formatter -> unit ->
+  (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
+  (int -> unit)
+;;
+(** Deprecated. Subsumed by [pp_get_formatter_out_functions].
+  @since 4.01.0
+*)
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 2eb4f857..39bf343d 100644
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: gc.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type stat = {
   minor_words : float;
   promoted_words : float;
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 14f263a4..5437ac0a 100644
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: gc.mli 12339 2012-04-11 03:51:09Z frisch $ *)
-
 (** Memory management control and statistics; finalised values. *)
 
 type stat =
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index 04e2ec80..dc80727d 100644
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: genlex.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type token =
     Kwd of string
   | Ident of string
@@ -21,7 +19,6 @@ type token =
   | String of string
   | Char of char
 
-
 (* The string buffering machinery *)
 
 let initial_buffer = String.create 32
@@ -81,7 +78,7 @@ let make_lexer keywords =
           Some '\'' -> Stream.junk strm__; Some (Char c)
         | _ -> raise (Stream.Error "")
         end
-    | Some '"' ->
+    | Some '\"' ->
         Stream.junk strm__;
         let s = strm__ in reset_buffer (); Some (String (string s))
     | Some '-' -> Stream.junk strm__; neg_number strm__
@@ -135,7 +132,7 @@ let make_lexer keywords =
     | _ -> Some (Float (float_of_string (get_string ())))
   and string (strm__ : _ Stream.t) =
     match Stream.peek strm__ with
-      Some '"' -> Stream.junk strm__; get_string ()
+      Some '\"' -> Stream.junk strm__; get_string ()
     | Some '\\' ->
         Stream.junk strm__;
         let c =
diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli
index 681b38bd..7858cbdc 100644
--- a/stdlib/genlex.mli
+++ b/stdlib/genlex.mli
@@ -11,12 +11,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: genlex.mli 12210 2012-03-08 19:52:03Z doligez $ *)
-
 (** A generic lexical analyzer.
 
 
-   This module implements a simple ``standard'' lexical analyzer, presented
+   This module implements a simple 'standard' lexical analyzer, presented
    as a function from character streams to token streams. It implements
    roughly the lexical conventions of OCaml, but is parameterized by the
    set of keywords of your language.
@@ -29,13 +27,14 @@
    to, for instance, [int], and would have rules such as:
 
    {[
-           let parse_expr = parser
-                  [< 'Int n >] -> n
-                | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
-                | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2
+           let rec parse_expr = parser
+             | [< n1 = parse_atom; n2 = parse_remainder n1 >] -> n2
+           and parse_atom = parser
+             | [< 'Int n >] -> n
+             | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
            and parse_remainder n1 = parser
-                  [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
-                | ...
+             | [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
+             | [< >] -> n1
    ]}
 
    One should notice that the use of the [parser] keyword and associated
@@ -49,9 +48,9 @@
    string literals, enclosed in double quotes; [Char] for
    character literals, enclosed in single quotes; [Ident] for
    identifiers (either sequences of letters, digits, underscores
-   and quotes, or sequences of ``operator characters'' such as
+   and quotes, or sequences of 'operator characters' such as
    [+], [*], etc); and [Kwd] for keywords (either identifiers or
-   single ``special characters'' such as [(], [}], etc). *)
+   single 'special characters' such as [(], [}], etc). *)
 type token =
     Kwd of string
   | Ident of string
@@ -66,6 +65,7 @@ val make_lexer : string list -> char Stream.t -> token Stream.t
    belongs to this list, and as [Ident s] otherwise.
    A special character [s] is returned as [Kwd s] if [s]
    belongs to this list, and cause a lexical error (exception
-   [Parse_error]) otherwise. Blanks and newlines are skipped.
-   Comments delimited by [(*] and [*)] are skipped as well,
-   and can be nested. *)
+   [Stream.Error] with the offending lexeme as its parameter) otherwise.
+   Blanks and newlines are skipped. Comments delimited by [(*] and [*)]
+   are skipped as well, and can be nested. A [Stream.Failure] exception
+   is raised if end of stream is unexpectedly reached.*)
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 6356c360..dcca372a 100644
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -11,12 +11,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hashtbl.ml 12475 2012-05-24 14:55:00Z doligez $ *)
-
 (* Hash tables *)
 
-external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
-external old_hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
+external seeded_hash_param :
+  int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
+external old_hash_param :
+  int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
 
 let hash x = seeded_hash_param 10 100 0 x
 let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index cc052629..bb75751f 100644
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hashtbl.mli 12453 2012-05-15 08:44:18Z lefessan $ *)
-
 (** Hash tables and hash functions.
 
    Hash tables are hashed association tables, with in-place modification.
diff --git a/stdlib/header.c b/stdlib/header.c
index a58cc149..cb3d9953 100644
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: header.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* The launcher for bytecode executables (if #! is not working) */
 
 #include 
diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index 0cc0a465..aa113ac9 100644
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -11,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: headernt.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #define STRICT
 #define WIN32_LEAN_AND_MEAN
 
@@ -157,7 +155,8 @@ void __declspec(noreturn) __cdecl headerentry()
     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"),
+    WriteFile(errh, msg_and_length(" not found or is not a bytecode"
+                                   " executable file\r\n"),
               &numwritten, NULL);
     ExitProcess(2);
 #if _MSC_VER >= 1200
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
index 15d5d3d3..e8e55ddc 100644
--- a/stdlib/int32.ml
+++ b/stdlib/int32.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int32.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [Int32]: 32-bit integers *)
 
 external neg : int32 -> int32 = "%int32_neg"
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index 9b4e3c81..fcd300a2 100644
--- a/stdlib/int32.mli
+++ b/stdlib/int32.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int32.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** 32-bit integers.
 
    This module provides operations on the type [int32]
@@ -136,14 +134,14 @@ val to_string : int32 -> string
 
 external bits_of_float : float -> int32 = "caml_int32_bits_of_float"
 (** Return the internal representation of the given float according
-   to the IEEE 754 floating-point ``single format'' bit layout.
+   to the IEEE 754 floating-point 'single format' bit layout.
    Bit 31 of the result represents the sign of the float;
    bits 30 to 23 represent the (biased) exponent; bits 22 to 0
    represent the mantissa. *)
 
 external float_of_bits : int32 -> float = "caml_int32_float_of_bits"
 (** Return the floating-point number whose internal representation,
-   according to the IEEE 754 floating-point ``single format'' bit layout,
+   according to the IEEE 754 floating-point 'single format' bit layout,
    is the given [int32]. *)
 
 type t = int32
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
index e5d52b2a..aa4add5f 100644
--- a/stdlib/int64.ml
+++ b/stdlib/int64.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int64.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [Int64]: 64-bit integers *)
 
 external neg : int64 -> int64 = "%int64_neg"
diff --git a/stdlib/int64.mli b/stdlib/int64.mli
index 73ce56d6..09b476f1 100644
--- a/stdlib/int64.mli
+++ b/stdlib/int64.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: int64.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** 64-bit integers.
 
    This module provides operations on the type [int64] of
@@ -158,14 +156,14 @@ val to_string : int64 -> string
 
 external bits_of_float : float -> int64 = "caml_int64_bits_of_float"
 (** Return the internal representation of the given float according
-   to the IEEE 754 floating-point ``double format'' bit layout.
+   to the IEEE 754 floating-point 'double format' bit layout.
    Bit 63 of the result represents the sign of the float;
    bits 62 to 52 represent the (biased) exponent; bits 51 to 0
    represent the mantissa. *)
 
 external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
 (** Return the floating-point number whose internal representation,
-   according to the IEEE 754 floating-point ``double format'' bit layout,
+   according to the IEEE 754 floating-point 'double format' bit layout,
    is the given [int64]. *)
 
 type t = int64
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index c77264b8..590be8fe 100644
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lazy.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
 (* Module [Lazy]: deferred computations *)
 
 
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
index 653d9ec4..6108a715 100644
--- a/stdlib/lazy.mli
+++ b/stdlib/lazy.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lazy.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Deferred computations. *)
 
 type 'a t = 'a lazy_t;;
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
index fb83bc8f..53748ad8 100644
--- a/stdlib/lexing.ml
+++ b/stdlib/lexing.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexing.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The run-time library for lexers generated by camllex *)
 
 type position = {
diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
index b5ed2f92..6d5406d6 100644
--- a/stdlib/lexing.mli
+++ b/stdlib/lexing.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexing.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** The run-time library for lexers generated by [ocamllex]. *)
 
 (** {6 Positions} *)
diff --git a/stdlib/list.ml b/stdlib/list.ml
index 7c8eeeeb..b7dd8269 100644
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: list.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* List operations *)
 
 let rec length_aux len = function
diff --git a/stdlib/list.mli b/stdlib/list.mli
index 312cbc85..33a9144d 100644
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: list.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
 (** List operations.
 
    Some functions are flagged as not tail-recursive.  A tail-recursive
diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml
index fae79c53..1f0684bf 100644
--- a/stdlib/listLabels.ml
+++ b/stdlib/listLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: listLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [ListLabels]: labelled List module *)
 
 include List
diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
index 31469d2e..8cf65147 100644
--- a/stdlib/listLabels.mli
+++ b/stdlib/listLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: listLabels.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
 (** List operations.
 
    Some functions are flagged as not tail-recursive.  A tail-recursive
diff --git a/stdlib/map.ml b/stdlib/map.ml
index 671903f5..7d65bc6b 100644
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: map.ml 12510 2012-05-30 11:28:51Z scherer $ *)
-
 module type OrderedType =
   sig
     type t
@@ -29,7 +27,8 @@ module type S =
     val add: key -> 'a -> 'a t -> 'a t
     val singleton: key -> 'a -> 'a t
     val remove: key -> 'a t -> 'a t
-    val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val merge:
+          (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
     val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
     val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
     val iter: (key -> 'a -> unit) -> 'a t -> unit
diff --git a/stdlib/map.mli b/stdlib/map.mli
index 0934bb73..6dd371b5 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: map.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Association tables over ordered types.
 
    This module implements applicative association tables, also known as
diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
index 1a988cc9..7a65a16a 100644
--- a/stdlib/marshal.ml
+++ b/stdlib/marshal.ml
@@ -11,11 +11,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
 type extern_flags =
     No_sharing
   | Closures
+  | Compat_32
 (* note: this type definition is used in 'byterun/debugger.c' *)
 
 external to_channel: out_channel -> 'a -> extern_flags list -> unit
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index 2b8af1da..f12af9fd 100644
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: marshal.mli 11922 2011-12-21 15:37:54Z doligez $ *)
-
 (** Marshaling of data structures.
 
    This module provides functions to encode arbitrary data structures
@@ -35,6 +33,13 @@
    Anything can happen at run-time if the object in the file does not
    belong to the given type.
 
+   OCaml exception values (of type [exn]) returned by the unmarhsaller
+   should not be pattern-matched over through [match ... with] or [try
+   ... with], because unmarshalling does not preserve the information
+   required for matching their exception constructor. Structural
+   equalities with other exception values, or most other uses such as
+   Printexc.to_string, will still work as expected.
+
    The representation of marshaled values is not human-readable,
    and uses bytes that are not printable characters. Therefore,
    input and output channels used in conjunction with [Marshal.to_channel]
@@ -47,20 +52,22 @@
 type extern_flags =
     No_sharing                          (** Don't preserve sharing *)
   | Closures                            (** Send function closures *)
+  | Compat_32                           (** Ensure 32-bit compatibility *)
 (** The flags to the [Marshal.to_*] functions below. *)
 
 val to_channel : out_channel -> 'a -> extern_flags list -> unit
 (** [Marshal.to_channel chan v flags] writes the representation
    of [v] on channel [chan]. The [flags] argument is a
    possibly empty list of flags that governs the marshaling
-   behavior with respect to sharing and functional values.
+   behavior with respect to sharing, functional values, and compatibility
+   between 32- and 64-bit platforms.
 
    If [flags] does not contain [Marshal.No_sharing], circularities
    and sharing inside the value [v] are detected and preserved
    in the sequence of bytes produced. In particular, this
    guarantees that marshaling always terminates. Sharing
    between values marshaled by successive calls to
-   [Marshal.to_channel] is not detected, though.
+   [Marshal.to_channel] is neither detected nor preserved, though.
    If [flags] contains [Marshal.No_sharing], sharing is ignored.
    This results in faster marshaling if [v] contains no shared
    substructures, but may cause slower marshaling and larger
@@ -69,7 +76,7 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit
 
    If [flags] does not contain [Marshal.Closures],
    marshaling fails when it encounters a functional value
-   inside [v]: only ``pure'' data structures, containing neither
+   inside [v]: only 'pure' data structures, containing neither
    functions nor objects, can safely be transmitted between
    different programs. If [flags] contains [Marshal.Closures],
    functional values will be marshaled as a position in the code
@@ -77,7 +84,20 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit
    only be read back in processes that run exactly the same program,
    with exactly the same compiled code. (This is checked
    at un-marshaling time, using an MD5 digest of the code
-   transmitted along with the code position.) *)
+   transmitted along with the code position.)
+
+   If [flags] contains [Marshal.Compat_32], marshaling fails when
+   it encounters an integer value outside the range [[-2{^30}, 2{^30}-1]]
+   of integers that are representable on a 32-bit platform.  This
+   ensures that marshaled data generated on a 64-bit platform can be
+   safely read back on a 32-bit platform.  If [flags] does not
+   contain [Marshal.Compat_32], integer values outside the
+   range [[-2{^30}, 2{^30}-1]] are marshaled, and can be read back on
+   a 64-bit platform, but will cause an error at un-marshaling time
+   when read back on a 32-bit platform.  The [Mashal.Compat_32] flag
+   only matters when marshaling is performed on a 64-bit platform;
+   it has no effect if marshaling is performed on a 32-bit platform.
+ *)
 
 external to_string :
   'a -> extern_flags list -> string = "caml_output_value_to_string"
diff --git a/stdlib/moreLabels.ml b/stdlib/moreLabels.ml
index ff1bc809..d7ac1589 100644
--- a/stdlib/moreLabels.ml
+++ b/stdlib/moreLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: moreLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [MoreLabels]: meta-module for compatibility labelled libraries *)
 
 module Hashtbl = Hashtbl
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 34982247..93f1222c 100644
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: moreLabels.mli 12453 2012-05-15 08:44:18Z lefessan $ *)
-
 (** Extra labeled libraries.
 
    This meta-module provides labelized version of the {!Hashtbl},
@@ -107,7 +105,8 @@ module Map : sig
       val add : key:key -> data:'a -> 'a t -> 'a t
       val singleton: key -> 'a -> 'a t
       val remove : key -> 'a t -> 'a t
-      val merge: f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+      val merge:
+          f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
       val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
       val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
       val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
@@ -161,6 +160,7 @@ module Set : sig
       val max_elt : t -> elt
       val choose : t -> elt
       val split: elt -> t -> t * bool * t
+      val find: elt -> t -> elt
     end
   module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
 end
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
index 88a54943..94c4b949 100644
--- a/stdlib/nativeint.ml
+++ b/stdlib/nativeint.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nativeint.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [Nativeint]: processor-native integers *)
 
 external neg: nativeint -> nativeint = "%nativeint_neg"
diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
index 84692ef8..eb2dde2c 100644
--- a/stdlib/nativeint.mli
+++ b/stdlib/nativeint.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nativeint.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Processor-native integers.
 
    This module provides operations on the type [nativeint] of
@@ -60,7 +58,8 @@ external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod"
 (** Integer remainder.  If [y] is not zero, the result
    of [Nativeint.rem x y] satisfies the following properties:
    [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and
-   [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)].
+   [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y)
+                      (Nativeint.rem x y)].
    If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *)
 
 val succ : nativeint -> nativeint
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index b9322889..a6f11586 100644
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: obj.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Operations on internal representations of values *)
 
 type t
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index fc60e2cb..9a5bd721 100644
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: obj.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Operations on internal representations of values.
 
    Not for the casual user.
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index b08a14ac..9d00360c 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 let copy = CamlinternalOO.copy
 external id : < .. > -> int = "%field1"
 let new_method = CamlinternalOO.public_method_label
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index 4ce25f9d..d1e5804f 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oo.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Operations on objects *)
 
 val copy : (< .. > as 'a) -> 'a
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 9837b7fc..76212824 100644
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsing.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The parsing engine *)
 
 open Lexing
@@ -74,6 +72,10 @@ type parser_output =
   | Compute_semantic_action
   | Call_error_function
 
+(* to avoid warnings *)
+let _ = [Read_token; Raise_parse_error; Grow_stacks_1; Grow_stacks_2;
+         Compute_semantic_action; Call_error_function]
+
 external parse_engine :
     parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
     = "caml_parse_engine"
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 5dff7d84..0532be16 100644
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsing.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** The run-time library for parsers generated by [ocamlyacc]. *)
 
 val symbol_start : unit -> int
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 590f5b9a..61fab1e0 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.ml 12019 2012-01-12 15:46:51Z doligez $ *)
-
 (* type 'a option = None | Some of 'a *)
 
 (* Exceptions *)
@@ -24,6 +22,11 @@ let invalid_arg s = raise(Invalid_argument s)
 
 exception Exit
 
+(* Composition operators *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+
 (* Comparisons *)
 
 external ( = ) : 'a -> 'a -> bool = "%equal"
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index a4cc1875..bab296a4 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: pervasives.mli 12416 2012-05-02 14:39:52Z doligez $ *)
-
 (** The initially opened module.
 
    This module provides the basic operations over the built-in types
@@ -38,7 +36,7 @@ val failwith : string -> 'a
 
 exception Exit
 (** The [Exit] exception is not raised by any library function.  It is
-    provided for use in your programs.*)
+    provided for use in your programs. *)
 
 
 (** {6 Comparisons} *)
@@ -122,7 +120,7 @@ external not : bool -> bool = "%boolnot"
 (** The boolean negation. *)
 
 external ( && ) : bool -> bool -> bool = "%sequand"
-(** The boolean ``and''. Evaluation is sequential, left-to-right:
+(** The boolean 'and'. Evaluation is sequential, left-to-right:
    in [e1 && e2], [e1] is evaluated first, and if it returns [false],
    [e2] is not evaluated at all. *)
 
@@ -130,7 +128,7 @@ external ( & ) : bool -> bool -> bool = "%sequand"
 (** @deprecated {!Pervasives.( && )} should be used instead. *)
 
 external ( || ) : bool -> bool -> bool = "%sequor"
-(** The boolean ``or''. Evaluation is sequential, left-to-right:
+(** The boolean 'or'. Evaluation is sequential, left-to-right:
    in [e1 || e2], [e1] is evaluated first, and if it returns [true],
    [e2] is not evaluated at all. *)
 
@@ -138,6 +136,20 @@ external ( or ) : bool -> bool -> bool = "%sequor"
 (** @deprecated {!Pervasives.( || )} should be used instead.*)
 
 
+(** {6 Composition operators} *)
+
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+(** Reverse-application operator: [x |> f |> g] is exactly equivalent
+ to [g (f (x))].
+   @since 4.01
+*)
+
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+(** Application operator: [g @@ f @@ x] is exactly equivalent to
+ [g (f (x))].
+   @since 4.01
+*)
+
 (** {6 Integer arithmetic} *)
 
 (** Integers are 31 bits wide (or 63 bits on 64-bit processors).
@@ -234,7 +246,7 @@ external ( asr ) : int -> int -> int = "%asrint"
    Floating-point operations never raise an exception on overflow,
    underflow, division by zero, etc.  Instead, special IEEE numbers
    are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
-   [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
+   [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
    for [0.0 /. 0.0].  These special numbers then propagate through
    floating-point computations as expected: for instance,
    [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
@@ -395,7 +407,7 @@ val neg_infinity : float
 val nan : float
 (** A special floating-point value denoting the result of an
    undefined operation such as [0.0 /. 0.0].  Stands for
-   ``not a number''.  Any floating-point operation with [nan] as
+   'not a number'.  Any floating-point operation with [nan] as
    argument returns [nan] as result.  As for floating-point comparisons,
    [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
    if one or both of their arguments is [nan]. *)
@@ -613,8 +625,7 @@ val open_out : string -> out_channel
 (** Open the named file for writing, and return a new output channel
    on that file, positionned at the beginning of the file. The
    file is truncated to zero length if it already exists. It
-   is created if it does not already exists.
-   Raise [Sys_error] if the file could not be opened. *)
+   is created if it does not already exists. *)
 
 val open_out_bin : string -> out_channel
 (** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
@@ -714,8 +725,7 @@ val set_binary_mode_out : out_channel -> bool -> unit
 
 val open_in : string -> in_channel
 (** Open the named file for reading, and return a new input channel
-   on that file, positionned at the beginning of the file.
-   Raise [Sys_error] if the file could not be opened. *)
+   on that file, positionned at the beginning of the file. *)
 
 val open_in_bin : string -> in_channel
 (** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
@@ -804,8 +814,7 @@ val close_in : in_channel -> unit
 (** Close the given channel.  Input functions raise a [Sys_error]
   exception when they are applied to a closed input channel,
   except [close_in], which does nothing when applied to an already
-  closed channel.  Note that [close_in] may raise [Sys_error] if
-  the operating system signals an error. *)
+  closed channel. *)
 
 val close_in_noerr : in_channel -> unit
 (** Same as [close_in], but ignore all errors. *)
@@ -868,24 +877,73 @@ external decr : int ref -> unit = "%decr"
 
 (** {6 Operations on format strings} *)
 
-(** Format strings are used to read and print data using formatted input
-    functions in module {!Scanf} and formatted output in modules {!Printf} and
-    {!Format}. *)
+(** Format strings are character strings with special lexical conventions
+  that defines the functionality of formatted input/output functions. Format
+  strings are used to read data with formatted input functions from module
+  {!Scanf} and to print data with formatted output functions from modules
+  {!Printf} and {!Format}.
+
+  Format strings are made of three kinds of entities:
+  - {e conversions specifications}, introduced by the special character ['%']
+    followed by one or more characters specifying what kind of argument to
+    read or print,
+  - {e formatting indications}, introduced by the special character ['@']
+    followed by one or more characters specifying how to read or print the
+    argument,
+  - {e plain characters} that are regular characters with usual lexical
+    conventions. Plain characters specify string literals to be read in the
+    input or printed in the output.
+
+  There is an additional lexical rule to escape the special characters ['%']
+  and ['@'] in format strings: if a special character follows a ['%']
+  character, it is treated as a plain character. In other words, ["%%"] is
+  considered as a plain ['%'] and ["%@"] as a plain ['@'].
+
+  For more information about conversion specifications and formatting
+  indications available, read the documentation of modules {!Scanf},
+  {!Printf} and {!Format}.
+*)
 
 (** Format strings have a general and highly polymorphic type
     [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
     The two simplified types, [format] and [format4] below are
-    included for backward compatibility with earlier releases of OCaml.
-    ['a] is the type of the parameters of the format,
-    ['b] is the type of the first argument given to
-         [%a] and [%t] printing functions,
-    ['c] is the type of the result of the [%a] and [%t] functions, and
-         also the type of the argument transmitted to the first argument
-         of [kprintf]-style functions,
-    ['d] is the result type for the [scanf]-style functions,
-    ['e] is the type of the receiver function for the [scanf]-style functions,
-    ['f] is the result type for the [printf]-style function.
- *)
+    included for backward compatibility with earlier releases of
+    OCaml.
+
+    The meaning of format string type parameters is as follows:
+
+    - ['a] is the type of the parameters of the format for formatted output
+      functions ([printf]-style functions);
+      ['a] is the type of the values read by the format for formatted input
+      functions ([scanf]-style functions).
+
+    - ['b] is the type of input source for formatted input functions and the
+      type of output target for formatted output functions.
+      For [printf]-style functions from module [Printf], ['b] is typically
+      [out_channel];
+      for [printf]-style functions from module [Format], ['b] is typically
+      [Format.formatter];
+      for [scanf]-style functions from module [Scanf], ['b] is typically
+      [Scanf.Scanning.in_channel].
+
+      Type argument ['b] is also the type of the first argument given to
+      user's defined printing functions for [%a] and [%t] conversions,
+      and user's defined reading functions for [%r] conversion.
+
+    - ['c] is the type of the result of the [%a] and [%t] printing
+      functions, and also the type of the argument transmitted to the
+      first argument of [kprintf]-style functions or to the
+      [kscanf]-style functions.
+
+    - ['d] is the type of parameters for the [scanf]-style functions.
+
+    - ['e] is the type of the receiver function for the [scanf]-style functions.
+
+    - ['f] is the final result type of a formatted input/output function
+      invocation: for the [printf]-style functions, it is typically [unit];
+      for the [scanf]-style functions, it is typically the result type of the
+      receiver function.
+*)
 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
@@ -897,14 +955,22 @@ external format_of_string :
   ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
   ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
 (** [format_of_string s] returns a format string read from the string
-    literal [s]. *)
+    literal [s].
+    Note: [format_of_string] can not convert a string argument that is not a
+    literal. If you need this functionality, use the more general
+    {!Scanf.format_from_string} function.
+*)
 
 val ( ^^ ) :
       ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
       ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
       ('a, 'b, 'c, 'd, 'g, 'h) format6
-(** [f1 ^^ f2] catenates formats [f1] and [f2].  The result is a format
-  that accepts arguments from [f1], then arguments from [f2]. *)
+(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
+  format string that behaves as the concatenation of format strings [f1] and
+  [f2]: in case of formatted output, it accepts arguments from [f1], then
+  arguments from [f2]; in case of formatted input, it returns results from
+  [f1], then results from [f2].
+*)
 
 
 (** {6 Program termination} *)
@@ -923,7 +989,7 @@ val at_exit : (unit -> unit) -> unit
    termination time. The functions registered with [at_exit]
    will be called when the program executes {!Pervasives.exit},
    or terminates, either normally or because of an uncaught exception.
-   The functions are called in ``last in, first out'' order:
+   The functions are called in 'last in, first out' order:
    the function most recently added with [at_exit] is called first. *)
 
 (**/**)
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index ab00c2a7..3324f6c4 100644
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printexc.ml 11187 2011-09-08 08:34:43Z xclerc $ *)
-
 open Printf;;
 
 let printers = ref []
@@ -60,7 +58,8 @@ let to_string x =
             sprintf locfmt file line char (char+6) "Undefined recursive module"
         | _ ->
             let x = Obj.repr x in
-            let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
+            let constructor =
+              (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
             constructor ^ (fields x) in
   conv !printers
 
@@ -80,6 +79,11 @@ let catch fct arg =
     eprintf "Uncaught exception: %s\n" (to_string x);
     exit 2
 
+type raw_backtrace
+
+external get_raw_backtrace:
+  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
+
 type loc_info =
   | Known_location of bool   (* is_raise *)
                     * string (* filename *)
@@ -88,8 +92,13 @@ type loc_info =
                     * int    (* end char *)
   | Unknown_location of bool (*is_raise*)
 
-external get_exception_backtrace:
-  unit -> loc_info array option = "caml_get_exception_backtrace"
+(* to avoid warning *)
+let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
+
+type backtrace = loc_info array
+
+external convert_raw_backtrace:
+  raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
 
 let format_loc_info pos li =
   let is_raise =
@@ -110,8 +119,8 @@ let format_loc_info pos li =
       sprintf "%s unknown location"
               info
 
-let print_backtrace outchan =
-  match get_exception_backtrace() with
+let print_exception_backtrace outchan backtrace =
+  match backtrace with
   | None ->
       fprintf outchan
         "(Program not linked with -g, cannot print stack backtrace)\n"
@@ -121,8 +130,15 @@ let print_backtrace outchan =
           fprintf outchan "%s\n" (format_loc_info i a.(i))
       done
 
-let get_backtrace () =
-  match get_exception_backtrace() with
+let print_raw_backtrace outchan raw_backtrace =
+  print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
+
+(* confusingly named: prints the global current backtrace *)
+let print_backtrace outchan =
+  print_raw_backtrace outchan (get_raw_backtrace ())
+
+let backtrace_to_string backtrace =
+  match backtrace with
   | None ->
      "(Program not linked with -g, cannot print stack backtrace)\n"
   | Some a ->
@@ -133,8 +149,22 @@ let get_backtrace () =
       done;
       Buffer.contents b
 
+let raw_backtrace_to_string raw_backtrace =
+  backtrace_to_string (convert_raw_backtrace raw_backtrace)
+
+(* confusingly named:
+   returns the *string* corresponding to the global current backtrace *)
+let get_backtrace () =
+  (* we could use the caml_get_exception_backtrace primitive here, but
+     we hope to deprecate it so it's better to just compose the
+     raw stuff *)
+  backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
+
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"
 
 let register_printer fn =
   printers := fn :: !printers
+
+
+external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index f389d85c..773fed81 100644
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -11,9 +11,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printexc.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
-(** Facilities for printing exceptions. *)
+(** Facilities for printing exceptions and inspecting current call stack. *)
 
 val to_string: exn -> string
 (** [Printexc.to_string e] returns a string representation of
@@ -84,3 +82,33 @@ val register_printer: (exn -> string option) -> unit
     the backtrace if it has itself raised an exception before.
     @since 3.11.2
 *)
+
+(** {6 Raw backtraces} *)
+
+type raw_backtrace
+
+(** The abstract type [backtrace] stores exception backtraces in
+    a low-level format, instead of directly exposing them as string as
+    the [get_backtrace()] function does.
+
+    This allows to pay the performance overhead of representation
+    conversion and formatting only at printing time, which is useful
+    if you want to record more backtrace than you actually print.
+*)
+
+val get_raw_backtrace: unit -> raw_backtrace
+val print_raw_backtrace: out_channel -> raw_backtrace -> unit
+val raw_backtrace_to_string: raw_backtrace -> string
+
+
+(** {6 Current call stack} *)
+
+val get_callstack: int -> raw_backtrace
+
+(** [Printexc.get_callstack n] returns a description of the top of the
+    call stack on the current program point (for the current thread),
+    with at most [n] entries.  (Note: this function is not related to
+    exceptions at all, despite being part of the [Printexc] module.)
+
+    @since 4.01.0
+*)
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index 9e0f05c5..38016920 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printf.ml 12014 2012-01-11 15:22:51Z doligez $ *)
-
 external format_float: string -> float -> string
   = "caml_format_float"
 external format_int: string -> int -> string
@@ -66,7 +64,7 @@ end
 let bad_conversion sfmt i c =
   invalid_arg
     ("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
-     string_of_int i ^ " in format string ``" ^ sfmt ^ "''")
+     string_of_int i ^ " in format string \'" ^ sfmt ^ "\'")
 ;;
 
 let bad_conversion_format fmt i c =
@@ -75,11 +73,12 @@ let bad_conversion_format fmt i c =
 
 let incomplete_format fmt =
   invalid_arg
-    ("Printf: premature end of format string ``" ^
-     Sformat.to_string fmt ^ "''")
+    ("Printf: premature end of format string \'" ^
+     Sformat.to_string fmt ^ "\'")
 ;;
 
-(* Parses a string conversion to return the specified length and the padding direction. *)
+(* Parses a string conversion to return the specified length and the
+   padding direction. *)
 let parse_string_conversion sfmt =
   let rec parse neg i =
     if i >= String.length sfmt then (0, neg) else
@@ -150,21 +149,21 @@ let extract_format fmt start stop widths =
 ;;
 
 let extract_format_int conv fmt start stop widths =
-   let sfmt = extract_format fmt start stop widths in
-   match conv with
-   | 'n' | 'N' ->
-     sfmt.[String.length sfmt - 1] <- 'u';
-     sfmt
-   | _ -> sfmt
+  let sfmt = extract_format fmt start stop widths in
+  match conv with
+  | 'n' | 'N' ->
+    sfmt.[String.length sfmt - 1] <- 'u';
+    sfmt
+  | _ -> sfmt
 ;;
 
 let extract_format_float conv fmt start stop widths =
-   let sfmt = extract_format fmt start stop widths in
-   match conv with
-   | 'F' ->
-     sfmt.[String.length sfmt - 1] <- 'g';
-     sfmt
-   | _ -> sfmt
+  let sfmt = extract_format fmt start stop widths in
+  match conv with
+  | 'F' ->
+    sfmt.[String.length sfmt - 1] <- 'g';
+    sfmt
+  | _ -> sfmt
 ;;
 
 (* Returns the position of the next character following the meta format
@@ -307,7 +306,7 @@ let ac_of_format fmt =
   ac
 ;;
 
-let count_arguments_of_format fmt =
+let count_printing_arguments_of_format fmt =
   let ac = ac_of_format fmt in
   (* For printing, only the regular arguments have to be counted. *)
   ac.ac_rglr
@@ -321,12 +320,12 @@ let list_iter_i f l =
   loop 0 l
 ;;
 
-(* ``Abstracting'' version of kprintf: returns a (curried) function that
+(* 'Abstracting' version of kprintf: returns a (curried) function that
    will print when totally applied.
    Note: in the following, we are careful not to be badly caught
    by the compiler optimizations for the representation of arrays. *)
 let kapr kpr fmt =
-  match count_arguments_of_format fmt with
+  match count_printing_arguments_of_format fmt with
   | 0 -> kpr fmt [||]
   | 1 -> Obj.magic (fun x ->
       let a = Array.make 1 (Obj.repr 0) in
@@ -372,17 +371,17 @@ type positional_specification =
 (* To scan an optional positional parameter specification,
    i.e. an integer followed by a [$].
 
-   Calling [got_spec] with appropriate arguments, we ``return'' a positional
+   Calling [got_spec] with appropriate arguments, we 'return' a positional
    specification and an index to go on scanning the [fmt] format at hand.
 
    Note that this is optimized for the regular case, i.e. no positional
-   parameter, since in this case we juste ``return'' the constant
-   [Spec_none]; in case we have a positional parameter, we ``return'' a
+   parameter, since in this case we juste 'return' the constant
+   [Spec_none]; in case we have a positional parameter, we 'return' a
    [Spec_index] [positional_specification] which is a bit more costly.
 
    Note also that we do not support [*$] specifications, since this would
    lead to type checking problems: a [*$] positional specification means
-   ``take the next argument to [printf] (which must be an integer value)'',
+   'take the next argument to [printf] (which must be an integer value)',
    name this integer value $n$; [*$] now designates parameter $n$.
 
    Unfortunately, the type of a parameter specified via a [*$] positional
@@ -455,10 +454,13 @@ let format_float_lexeme =
     valid_float_loop 0 in
 
   (fun sfmt x ->
-   let s = format_float sfmt x in
    match classify_float x with
-   | FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s
-   | FP_nan | FP_infinite -> s)
+   | FP_normal | FP_subnormal | FP_zero ->
+       make_valid_float_lexeme (format_float sfmt x)
+   | FP_infinite ->
+       if x < 0.0 then "neg_infinity" else "infinity"
+   | FP_nan ->
+       "nan")
 ;;
 
 (* Decode a format string and act on it.
@@ -467,11 +469,16 @@ let format_float_lexeme =
    After consuming the appropriate number of arguments and formatting
    them, one of the following five continuations described below is called:
 
-   - [cont_s] for outputting a string (arguments: arg num, string, next pos)
-   - [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos)
-   - [cont_t] for performing a %t action (arguments: arg num, fn, next pos)
-   - [cont_f] for performing a flush action (arguments: arg num, next pos)
-   - [cont_m] for performing a %( action (arguments: arg num, sfmt, next pos)
+   - [cont_s] for outputting a string
+     (arguments: arg num, string, next pos)
+   - [cont_a] for performing a %a action
+     (arguments: arg num, fn, arg, next pos)
+   - [cont_t] for performing a %t action
+     (arguments: arg num, fn, next pos)
+   - [cont_f] for performing a flush action
+     (arguments: arg num, next pos)
+   - [cont_m] for performing a %( action
+     (arguments: arg num, sfmt, next pos)
 
    "arg num" is the index in array [args] of the next argument to [printf].
    "next pos" is the position in [fmt] of the first character following
@@ -536,8 +543,11 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
     | 'F' as conv ->
       let (x : float) = get_arg spec n in
       let s =
-        if widths = [] then Pervasives.string_of_float x else
-        format_float_lexeme (extract_format_float conv fmt pos i widths) x in
+        format_float_lexeme
+          (if widths = []
+           then "%.12g"
+           else extract_format_float conv fmt pos i widths)
+          x in
       cont_s (next_index spec n) s (succ i)
     | 'B' | 'b' ->
       let (x : bool) = get_arg spec n in
@@ -579,15 +589,15 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
     | '{' | '(' as conv (* ')' '}' *) ->
       let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
       let i = succ i in
-      let j = sub_format_for_printf conv fmt i in
+      let i = sub_format_for_printf conv fmt i in
       if conv = '{' (* '}' *) then
         (* Just print the format argument as a specification. *)
         cont_s
           (next_index spec n)
           (summarize_format_type xf)
-          j else
+          i else
         (* Use the format argument instead of the format specification. *)
-        cont_m (next_index spec n) xf j
+        cont_m (next_index spec n) xf i
     | (* '(' *) ')' ->
       cont_s n "" (succ i)
     | conv ->
@@ -601,6 +611,8 @@ let mkprintf to_s get_out outc outs flush k fmt =
   (* [out] is global to this definition of [pr], and must be shared by all its
      recursive calls (if any). *)
   let out = get_out fmt in
+  let outc c = outc out c in
+  let outs s = outs out s in
 
   let rec pr k n fmt v =
 
@@ -610,25 +622,28 @@ let mkprintf to_s get_out outc outs flush k fmt =
        if i >= len then Obj.magic (k out) else
        match Sformat.unsafe_get fmt i with
        | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
-       |  c  -> outc out c; doprn n (succ i)
+       |  c  -> outc c; doprn n (succ i)
+
     and cont_s n s i =
-      outs out s; doprn n i
+      outs s; doprn n i
     and cont_a n printer arg i =
       if to_s then
-        outs out ((Obj.magic printer : unit -> _ -> string) () arg)
+        outs ((Obj.magic printer : unit -> _ -> string) () arg)
       else
         printer out arg;
       doprn n i
     and cont_t n printer i =
       if to_s then
-        outs out ((Obj.magic printer : unit -> string) ())
+        outs ((Obj.magic printer : unit -> string) ())
       else
         printer out;
       doprn n i
     and cont_f n i =
       flush out; doprn n i
     and cont_m n xf i =
-      let m = Sformat.add_int_index (count_arguments_of_format xf) n in
+      let m =
+        Sformat.add_int_index
+          (count_printing_arguments_of_format xf) n in
       pr (Obj.magic (fun _ -> doprn m i)) n xf v in
 
     doprn n 0 in
@@ -638,12 +653,19 @@ let mkprintf to_s get_out outc outs flush k fmt =
   kapr kpr fmt
 ;;
 
+(**************************************************************
+
+  Defining [fprintf] and various flavors of [fprintf].
+
+ **************************************************************)
+
 let kfprintf k oc =
   mkprintf false (fun _ -> oc) output_char output_string flush k
 ;;
-let ifprintf _ = kapr (fun _ -> Obj.magic ignore);;
+let ikfprintf k oc = kapr (fun _ _ -> Obj.magic (k oc));;
 
 let fprintf oc = kfprintf ignore oc;;
+let ifprintf oc = ikfprintf ignore oc;;
 let printf fmt = fprintf stdout fmt;;
 let eprintf fmt = fprintf stderr fmt;;
 
@@ -671,7 +693,12 @@ let ksprintf k =
 
 let sprintf fmt = ksprintf (fun s -> s) fmt;;
 
-(* Obsolete and deprecated. *)
+(**************************************************************
+
+  Deprecated stuff.
+
+ **************************************************************)
+
 let kprintf = ksprintf;;
 
 (* For OCaml system internal use only: needed to implement modules [Format]
@@ -693,6 +720,9 @@ module CamlinternalPr = struct
 
     let ac_of_format = ac_of_format;;
 
+    let count_printing_arguments_of_format =
+      count_printing_arguments_of_format;;
+
     let sub_format = sub_format;;
 
     let summarize_format_type = summarize_format_type;;
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index 9dc472dc..a75a6418 100644
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printf.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Formatted output functions. *)
 
 val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
@@ -47,7 +45,8 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    - [s]: insert a string argument.
    - [S]: convert a string argument to OCaml syntax (double quotes, escapes).
    - [c]: insert a character argument.
-   - [C]: convert a character argument to OCaml syntax (single quotes, escapes).
+   - [C]: convert a character argument to OCaml syntax
+     (single quotes, escapes).
    - [f]: convert a floating-point argument to decimal notation,
      in the style [dddd.ddd].
    - [F]: convert a floating-point argument to OCaml syntax ([dddd.]
@@ -73,8 +72,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
      [fprintf] at the current point.
    - [t]: same as [%a], but take only one argument (with type
      [out_channel -> unit]) and apply it to [outchan].
-   - [\{ fmt %\}]: convert a format string argument. The argument must
-     have the same type as the internal format string [fmt].
+   - [\{ fmt %\}]: convert a format string argument to its type digest.
+     The argument must have the same type as the internal format string
+     [fmt].
    - [( fmt %)]: format string substitution. Take a format string
      argument and substitute it to the internal format string [fmt]
      to print following arguments. The argument must have the same
@@ -82,7 +82,8 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    - [!]: take no argument and flush the output.
    - [%]: take no argument and output one [%] character.
    - [\@]: take no argument and output one [\@] character.
-   - [,]: take no argument and do nothing.
+   - [,]: take no argument and output nothing: a no-op delimiter for
+     conversion specifications.
 
    The optional [flags] are:
    - [-]: left-justify the output (default is right justification).
@@ -115,12 +116,6 @@ val printf : ('a, out_channel, unit) format -> 'a
 val eprintf : ('a, out_channel, unit) format -> 'a
 (** Same as {!Printf.fprintf}, but output on [stderr]. *)
 
-val ifprintf : 'a -> ('b, 'a, unit) format -> 'b
-(** Same as {!Printf.fprintf}, but does not print anything.
-    Useful to ignore some material when conditionally printing.
-    @since 3.10.0
-*)
-
 val sprintf : ('a, unit, string) format -> 'a
 (** Same as {!Printf.fprintf}, but instead of printing on an output channel,
    return a string containing the result of formatting the arguments. *)
@@ -130,6 +125,12 @@ val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
    append the formatted arguments to the given extensible buffer
    (see module {!Buffer}). *)
 
+val ifprintf : 'a -> ('b, 'a, unit) format -> 'b
+(** Same as {!Printf.fprintf}, but does not print anything.
+    Useful to ignore some material when conditionally printing.
+    @since 3.10.0
+*)
+
 (** Formatted output functions with continuations. *)
 
 val kfprintf : (out_channel -> 'a) -> out_channel ->
@@ -139,6 +140,14 @@ val kfprintf : (out_channel -> 'a) -> out_channel ->
    @since 3.09.0
 *)
 
+val ikfprintf : (out_channel -> 'a) -> out_channel ->
+              ('b, out_channel, unit, 'a) format4 -> 'b
+;;
+(** Same as [kfprintf] above, but does not print anything.
+   Useful to ignore some material when conditionally printing.
+   @since 4.0
+*)
+
 val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 (** Same as [sprintf] above, but instead of returning the string,
    passes it to the first argument.
@@ -171,6 +180,7 @@ module CamlinternalPr : sig
     external unsafe_index_of_int : int -> index = "%identity";;
 
     val succ_index : index -> index;;
+    val add_int_index : int -> index -> index;;
 
     val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;;
     val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;;
@@ -194,6 +204,8 @@ module CamlinternalPr : sig
     };;
 
     val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;;
+    val count_printing_arguments_of_format :
+      ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int;;
 
     val sub_format :
         (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) ->
diff --git a/stdlib/queue.ml b/stdlib/queue.ml
index 02c6c77a..fb920d8c 100644
--- a/stdlib/queue.ml
+++ b/stdlib/queue.ml
@@ -2,7 +2,7 @@
 (*                                                                     *)
 (*                                OCaml                                *)
 (*                                                                     *)
-(*        François Pottier, projet Cristal, INRIA Rocquencourt         *)
+(*        Francois Pottier, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: queue.ml 12163 2012-02-18 09:36:13Z lefessan $ *)
-
 exception Empty
 
 (* OCaml currently does not allow the components of a sum type to be
@@ -109,14 +107,15 @@ let copy q =
       next = tail'
     } in
 
-    let rec copy cell =
-      if cell == tail then tail'
-      else {
+    let rec copy prev cell =
+      if cell != tail
+      then let res = {
         content = cell.content;
-        next = copy cell.next
-      } in
+        next = tail'
+      } in prev.next <- res;
+      copy res cell.next in
 
-    tail'.next <- copy tail.next;
+    copy tail' tail.next;
     {
       length = q.length;
       tail = tail'
diff --git a/stdlib/queue.mli b/stdlib/queue.mli
index 4d235d4d..55e89883 100644
--- a/stdlib/queue.mli
+++ b/stdlib/queue.mli
@@ -11,11 +11,13 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: queue.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** First-in first-out queues.
 
    This module implements queues (FIFOs), with in-place modification.
+
+   {b Warning} This module is not thread-safe: each {!Queue.t} value
+   must be protected from concurrent access (e.g. with a {!Mutex.t}).
+   Failure to do so can lead to a crash.
 *)
 
 type 'a t
diff --git a/stdlib/random.ml b/stdlib/random.ml
index aa625bfb..f7b6e3be 100644
--- a/stdlib/random.ml
+++ b/stdlib/random.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: random.ml 12333 2012-04-10 15:08:10Z doligez $ *)
-
 (* Pseudo-random number generator
    This is a lagged-Fibonacci F(55, 24, +) with a modified addition
    function to enhance the mixing of bits.
@@ -145,18 +143,19 @@ module State = struct
 
 end;;
 
-(* This is the state you get with [init 27182818]. *)
+(* This is the state you get with [init 27182818] and then applying
+   the "land 0x3FFFFFFF" filter to them.  See #5575, #5793, #5977. *)
 let default = {
   State.st = [|
-      0x7ae2522b; 0x5d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x7b086c47;
-      0x16d467d6; 0x501d91c7; 0x321df177; 0x4176c193; 0x1ff72bf1; 0x5e889109;
-      0x0b464b18; 0x6b86b97c; 0x4891da48; 0x03137463; 0x485ac5a1; 0x15d61f2f;
-      0x7bced359; 0x69c1c132; 0x7a86766e; 0x366d8c86; 0x1f5b6222; 0x7ce1b59f;
-      0x2ebf78e1; 0x67cd1b86; 0x658f3dc3; 0x789a8194; 0x42e4c44c; 0x58c43f7d;
-      0x0f6e534f; 0x1e7df359; 0x455d0b7e; 0x10e84e7e; 0x126198e4; 0x4e7722cb;
-      0x5cbede28; 0x7391b964; 0x7d40e92a; 0x4c59933d; 0x0b8cd0b7; 0x64efff1c;
-      0x2803fdaa; 0x08ebc72e; 0x4f522e32; 0x45398edc; 0x2144a04c; 0x4aef3cbd;
-      0x41ad4719; 0x75b93cd6; 0x2a559d4f; 0x5e6fd768; 0x66e27f36; 0x186f18c3;
+      0x3ae2522b; 0x1d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x3b086c47;
+      0x16d467d6; 0x101d91c7; 0x321df177; 0x0176c193; 0x1ff72bf1; 0x1e889109;
+      0x0b464b18; 0x2b86b97c; 0x0891da48; 0x03137463; 0x085ac5a1; 0x15d61f2f;
+      0x3bced359; 0x29c1c132; 0x3a86766e; 0x366d8c86; 0x1f5b6222; 0x3ce1b59f;
+      0x2ebf78e1; 0x27cd1b86; 0x258f3dc3; 0x389a8194; 0x02e4c44c; 0x18c43f7d;
+      0x0f6e534f; 0x1e7df359; 0x055d0b7e; 0x10e84e7e; 0x126198e4; 0x0e7722cb;
+      0x1cbede28; 0x3391b964; 0x3d40e92a; 0x0c59933d; 0x0b8cd0b7; 0x24efff1c;
+      0x2803fdaa; 0x08ebc72e; 0x0f522e32; 0x05398edc; 0x2144a04c; 0x0aef3cbd;
+      0x01ad4719; 0x35b93cd6; 0x2a559d4f; 0x1e6fd768; 0x26e27f36; 0x186f18c3;
       0x2fbf967a;
     |];
   State.idx = 0;
diff --git a/stdlib/random.mli b/stdlib/random.mli
index d234a07d..90f396f0 100644
--- a/stdlib/random.mli
+++ b/stdlib/random.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: random.mli 12352 2012-04-13 12:43:24Z doligez $ *)
-
 (** Pseudo-random number generators (PRNG). *)
 
 (** {6 Basic functions} *)
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index a5e13700..8f694fd3 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scanf.ml 12506 2012-05-29 12:51:50Z frisch $ *)
-
 (* The run-time library for scanners. *)
 
 (* Scanning buffers. *)
@@ -260,7 +258,7 @@ module Scanning : SCANNING = struct
 
      We cannot prevent the scanning mechanism to use one lookahead character,
      if needed by the semantics of the format string specifications (e.g. a
-     trailing ``skip space'' specification in the format string); in this case,
+     trailing 'skip space' specification in the format string); in this case,
      the mandatory lookahead character is indeed read from the input and not
      used to return the token read. It is thus mandatory to be able to store
      an unused lookahead character somewhere to get it as the first character
@@ -294,8 +292,8 @@ module Scanning : SCANNING = struct
      This phenomenon of reading mess is even worse when one defines more than
      one scanning buffer reading from the same input channel
      [ic]. Unfortunately, we have no simple way to get rid of this problem
-     (unless the basic input channel API is modified to offer a ``consider this
-     char as unread'' procedure to keep back the unused lookahead character as
+     (unless the basic input channel API is modified to offer a 'consider this
+     char as unread' procedure to keep back the unused lookahead character as
      available in the input channel for further reading).
 
      To prevent some of the confusion the scanning buffer allocation function
@@ -339,16 +337,17 @@ module Scanning : SCANNING = struct
   let from_ic_close_at_end = from_ic scan_close_at_end;;
 
   (* The scanning buffer reading from [Pervasives.stdin].
-     One could try to define [stdib] as a scanning buffer reading a character at a
-     time (no bufferization at all), but unfortunately the top-level
-     interaction would be wrong.
-     This is due to some kind of ``race condition'' when reading from [Pervasives.stdin],
+     One could try to define [stdib] as a scanning buffer reading a character
+     at a time (no bufferization at all), but unfortunately the top-level
+     interaction would be wrong. This is due to some kind of
+     'race condition' when reading from [Pervasives.stdin],
      since the interactive compiler and [scanf] will simultaneously read the
-     material they need from [Pervasives.stdin]; then, confusion will result from what should
-     be read by the top-level and what should be read by [scanf].
+     material they need from [Pervasives.stdin]; then, confusion will result
+     from what should be read by the top-level and what should be read
+     by [scanf].
      This is even more complicated by the one character lookahead that [scanf]
-     is sometimes obliged to maintain: the lookahead character will be available
-     for the next ([scanf]) entry, seemingly coming from nowhere.
+     is sometimes obliged to maintain: the lookahead character will be
+     available for the next ([scanf]) entry, seemingly coming from nowhere.
      Also no [End_of_file] is raised when reading from stdin: if not enough
      characters have been read, we simply ask to read more. *)
   let stdin =
@@ -449,12 +448,12 @@ let bad_conversion fmt i c =
   invalid_arg
     (Printf.sprintf
        "scanf: bad conversion %%%C, at char number %i \
-        in format string ``%s''" c i (Sformat.to_string fmt))
+        in format string \'%s\'" c i (Sformat.to_string fmt))
 ;;
 
 let incomplete_format fmt =
   invalid_arg
-    (Printf.sprintf "scanf: premature end of format string ``%s''"
+    (Printf.sprintf "scanf: premature end of format string \'%s\'"
        (Sformat.to_string fmt))
 ;;
 
@@ -472,7 +471,7 @@ let character_mismatch c ci =
 
 let format_mismatch_err fmt1 fmt2 =
   Printf.sprintf
-    "format read ``%s'' does not match specification ``%s''" fmt1 fmt2
+    "format read \'%s\' does not match specification \'%s\'" fmt1 fmt2
 ;;
 
 let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);;
@@ -483,19 +482,19 @@ let compatible_format_type fmt1 fmt2 =
   Tformat.summarize_format_type (string_to_format fmt2);;
 
 (* Checking that [c] is indeed in the input, then skips it.
-   In this case, the character c has been explicitly specified in the
+   In this case, the character [c] has been explicitly specified in the
    format as being mandatory in the input; hence we should fail with
    End_of_file in case of end_of_input. (Remember that Scan_failure is raised
    only when (we can prove by evidence) that the input does not match the
    format string given. We must thus differentiate End_of_file as an error
    due to lack of input, and Scan_failure which is due to provably wrong
-   input. I am not sure this is worth to burden: it is complex and somehow
+   input. I am not sure this is worth the burden: it is complex and somehow
    subliminal; should be clearer to fail with Scan_failure "Not enough input
    to complete scanning"!)
 
    That's why, waiting for a better solution, we use checked_peek_char here.
-   We are also careful to treat "\r\n" in the input as a end of line marker: it
-   always matches a '\n' specification in the input format string. *)
+   We are also careful to treat "\r\n" in the input as an end of line marker:
+   it always matches a '\n' specification in the input format string. *)
 let rec check_char ib c =
   let ci = Scanning.checked_peek_char ib in
   if ci = c then Scanning.invalidate_current_char ib else begin
@@ -613,7 +612,7 @@ let scan_decimal_digits_plus width ib =
     bad_input (Printf.sprintf "character %C is not a decimal digit" c)
 ;;
 
-let scan_digits_plus digitp width ib =
+let scan_digits_plus basis digitp width ib =
   (* To scan numbers from other bases, we use a predicate argument to
      scan_digits. *)
   let rec scan_digits width =
@@ -638,7 +637,7 @@ let scan_digits_plus digitp width ib =
     let width = Scanning.store_char width ib c in
     scan_digits width
   else
-    bad_input (Printf.sprintf "character %C is not a digit" c)
+    bad_input (Printf.sprintf "character %C is not a valid %s digit" c basis)
 ;;
 
 let is_binary_digit = function
@@ -646,21 +645,21 @@ let is_binary_digit = function
   | _ -> false
 ;;
 
-let scan_binary_int = scan_digits_plus is_binary_digit;;
+let scan_binary_int = scan_digits_plus "binary" is_binary_digit;;
 
 let is_octal_digit = function
   | '0' .. '7' -> true
   | _ -> false
 ;;
 
-let scan_octal_int = scan_digits_plus is_octal_digit;;
+let scan_octal_int = scan_digits_plus "octal" is_octal_digit;;
 
 let is_hexa_digit = function
   | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
   | _ -> false
 ;;
 
-let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
+let scan_hexadecimal_int = scan_digits_plus "hexadecimal" is_hexa_digit;;
 
 (* Scan a decimal integer. *)
 let scan_unsigned_decimal_int = scan_decimal_digits_plus;;
@@ -935,8 +934,10 @@ let scan_Char width ib =
 
   and find_char width =
     match check_next_char_for_char width ib with
-    | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
-    | c -> find_stop (Scanning.store_char width ib c)
+    | '\\' ->
+      find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
+    | c ->
+      find_stop (Scanning.store_char width ib c)
 
   and find_stop width =
     match check_next_char_for_char width ib with
@@ -1264,7 +1265,7 @@ let rec skip_whites ib =
 let scanf_bad_input ib = function
   | Scan_failure s | Failure s ->
     let i = Scanning.char_count ib in
-    bad_input (Printf.sprintf "scanf: bad input at char number %i: ``%s''" i s)
+    bad_input (Printf.sprintf "scanf: bad input at char number %i: \'%s\'" i s)
   | x -> raise x
 ;;
 
@@ -1351,7 +1352,8 @@ let scan_format ib ef fmt rv f =
         if i > lim then incomplete_format fmt else
         match Sformat.get fmt i with
         | '0' .. '9' as conv ->
-          let width, i = read_int_literal (decimal_value_of_char conv) (succ i) in
+          let width, i =
+            read_int_literal (decimal_value_of_char conv) (succ i) in
           Some width, i
         | _ -> None, i
 
@@ -1451,20 +1453,34 @@ let scan_format ib ef fmt rv f =
         | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end
       | '(' | '{' as conv (* ')' '}' *) ->
         let i = succ i in
-        (* Find the static specification for the format to read. *)
+        (* Find [mf], the static specification for the format to read. *)
         let j =
           Tformat.sub_format
             incomplete_format bad_conversion conv fmt i in
         let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in
-        (* Read the specified format string in the input buffer,
-           and check its correctness. *)
+        (* Read [rf], the specified format string in the input buffer,
+           and check its correctness w.r.t. [mf]. *)
         let _x = scan_String width ib in
         let rf = token_string ib in
         if not (compatible_format_type rf mf) then format_mismatch rf mf else
+        (* Proceed according to the kind of metaformat found:
+           - %{ mf %} simply returns [rf] as the token read,
+           - %( mf %) returns [rf] as the first token read, then
+             returns a second token obtained by scanning the input with
+             format string [rf].
+           Behaviour for %( mf %) is mandatory for sake of format string
+           typechecking specification. To get pure format string
+           substitution behaviour, you should use %_( mf %) that skips the
+           first (format string) token and hence properly substitutes [mf] by
+           [rf] in the format string argument.
+        *)
         (* For conversion %{%}, just return this format string as the token
-           read. *)
+           read and go on with the rest of the format string argument. *)
         if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else
-        (* Or else, read according to the format string just read. *)
+        (* Or else, return this format string as the first token read;
+           then continue scanning using this format string to get
+           the following token read;
+           finally go on with the rest of the format string argument. *)
         let ir, nf = scan (string_to_format rf) ir (stack f rf) 0 in
         (* Return the format string read and the value just read,
            then go on with the rest of the format. *)
@@ -1549,6 +1565,7 @@ let format_from_string s fmt =
 
 let unescaped s =
   sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
+;;
 
 (*
  Local Variables:
diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 2e9d4bc3..43bd3d05 100644
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scanf.mli 12571 2012-06-05 18:21:50Z doligez $ *)
-
 (** Formatted input functions. *)
 
 (** {6 Introduction} *)
@@ -45,7 +43,8 @@
     material with module {!Printf} or {!Format}),
 
     - [f] is a function that has as many arguments as the number of values to
-    read in the input. *)
+    read in the input.
+*)
 
 (** {7 A simple example} *)
 
@@ -62,7 +61,8 @@
     then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the
     standard input and returns [f n] (that is [n + 1]). Thus, if we
     evaluate [bscanf stdin "%d" f], and then enter [41] at the
-    keyboard, we get [42] as the final result. *)
+    keyboard, we get [42] as the final result.
+*)
 
 (** {7 Formatted input as a functional feature} *)
 
@@ -75,8 +75,9 @@
     useful additions to easily define complex tokens; as expected within a
     functional programming language, the formatted input functions also
     support polymorphism, in particular arbitrary interaction with
-    polymorphic user-defined scanners.  Furthermore, the OCaml formatted input
-    facility is fully type-checked at compile time. *)
+    polymorphic user-defined scanners. Furthermore, the OCaml formatted input
+    facility is fully type-checked at compile time.
+*)
 
 (** {6 Formatted input channel} *)
 
@@ -99,9 +100,10 @@ type scanbuf = in_channel;;
     input, and a token buffer to store the string matched so far.
 
     Note: a scanning action may often require to examine one character in
-    advance; when this ``lookahead'' character does not belong to the token
+    advance; when this 'lookahead' character does not belong to the token
     read, it is stored back in the scanning buffer and becomes the next
-    character yet to be read. *)
+    character yet to be read.
+*)
 
 val stdin : in_channel;;
 (** The standard input notion for the [Scanf] module.
@@ -123,7 +125,7 @@ type file_name = string;;
 
 val open_in : file_name -> in_channel;;
 (** [Scanning.open_in fname] returns a formatted input channel for bufferized
-    reading in text mode of file [fname].
+    reading in text mode from file [fname].
 
     Note:
     [open_in] returns a formatted input channel that efficiently reads
@@ -135,7 +137,7 @@ val open_in : file_name -> in_channel;;
 
 val open_in_bin : file_name -> in_channel;;
 (** [Scanning.open_in_bin fname] returns a formatted input channel for
-    bufferized reading in binary mode of file [fname].
+    bufferized reading in binary mode from file [fname].
     @since 3.12.0
 *)
 
@@ -154,7 +156,8 @@ val from_string : string -> in_channel;;
 (** [Scanning.from_string s] returns a formatted input channel which reads
     from the given string.
     Reading starts from the first character in the string.
-    The end-of-input condition is set when the end of the string is reached. *)
+    The end-of-input condition is set when the end of the string is reached.
+*)
 
 val from_function : (unit -> char) -> in_channel;;
 (** [Scanning.from_function f] returns a formatted input channel with the
@@ -163,20 +166,24 @@ val from_function : (unit -> char) -> in_channel;;
     When scanning needs one more character, the given function is called.
 
     When the function has no more character to provide, it {e must} signal an
-    end-of-input condition by raising the exception [End_of_file]. *)
+    end-of-input condition by raising the exception [End_of_file].
+*)
 
 val from_channel : Pervasives.in_channel -> in_channel;;
 (** [Scanning.from_channel ic] returns a formatted input channel which reads
     from the regular input channel [ic] argument, starting at the current
-    reading position. *)
+    reading position.
+*)
 
 val end_of_input : in_channel -> bool;;
 (** [Scanning.end_of_input ic] tests the end-of-input condition of the given
-    formatted input channel. *)
+    formatted input channel.
+*)
 
 val beginning_of_input : in_channel -> bool;;
 (** [Scanning.beginning_of_input ic] tests the beginning of input condition of
-    the given formatted input channel. *)
+    the given formatted input channel.
+*)
 
 val name_of_input : in_channel -> string;;
 (** [Scanning.name_of_input ic] returns the name of the character source
@@ -186,7 +193,8 @@ val name_of_input : in_channel -> string;;
 
 val stdib : in_channel;;
 (** A deprecated alias for [Scanning.stdin], the scanning buffer reading from
-    [Pervasives.stdin]. *)
+    [Pervasives.stdin].
+*)
 
 end;;
 
@@ -216,8 +224,9 @@ type ('a, 'b, 'c, 'd) scanner =
 *)
 
 exception Scan_failure of string;;
-(** The exception that formatted input functions raise when the input cannot be
-    read according to the given format. *)
+(** The exception that formatted input functions raise when the input cannot
+    be read according to the given format.
+*)
 
 (** {6 The general formatted input function} *)
 
@@ -231,18 +240,21 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     [Scanf.sscanf "x=  1" "%s = %i" f] returns [2].
 
     Arguments [r1] to [rN] are user-defined input functions that read the
-    argument corresponding to a [%r] conversion. *)
+    argument corresponding to the [%r] conversions specified in the format
+    string.
+*)
 
 (** {6 Format string description} *)
 
-(** The format is a character string which contains three types of
+(** The format string is a character string which contains three types of
     objects:
     - plain characters, which are simply matched with the characters of the
       input (with a special case for space and line feed, see {!Scanf.space}),
     - conversion specifications, each of which causes reading and conversion of
       one argument for the function [f] (see {!Scanf.conversion}),
     - scanning indications to specify boundaries of tokens
-      (see scanning {!Scanf.indication}). *)
+      (see scanning {!Scanf.indication}).
+*)
 
 (** {7:space The space character in format strings} *)
 
@@ -251,7 +263,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     special exceptions to this rule: the space character ([' '] or ASCII code
     32) and the line feed character (['\n'] or ASCII code 10).
     A space does not match a single space character, but any amount of
-    ``whitespace'' in the input. More precisely, a space inside the format
+    'whitespace' in the input. More precisely, a space inside the format
     string matches {e any number} of tab, space, line feed and carriage
     return characters. Similarly, a line feed character in the format string
     matches either a single line feed or a carriage return followed by a line
@@ -261,7 +273,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     also matches no amount of whitespace at all; hence, the call [bscanf ib
     "Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an
     input with various whitespace in it, such as [Price = 1 $],
-    [Price  =  1    $], or even [Price=1$]. *)
+    [Price  =  1    $], or even [Price=1$].
+*)
 
 (** {7:conversion Conversion specifications in format strings} *)
 
@@ -326,30 +339,33 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
       function and applies it to the scanning buffer [ib] to read the
       next argument. The input function [ri] must therefore have type
       [Scanning.in_channel -> 'a] and the argument read has type ['a].
-    - [\{ fmt %\}]: reads a format string argument.  The format string
+    - [\{ fmt %\}]: reads a format string argument. The format string
       read must have the same type as the format string specification
-      [fmt].  For instance, ["%{ %i %}"] reads any format string that
+      [fmt]. For instance, ["%{ %i %}"] reads any format string that
       can read a value of type [int]; hence, if [s] is the string
       ["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"]
       succeeds and returns the format string ["number is %u"].
-    - [\( fmt %\)]: scanning format substitution.
-      Reads a format string and then goes on scanning with the format string
-      read, instead of using [fmt].
-      The format string read must have the same type as the format string
+    - [\( fmt %\)]: scanning sub-format substitution.
+      Reads a format string [rf] in the input, then goes on scanning with
+      [rf] instead of scanning with [fmt].
+      The format string [rf] must have the same type as the format string
       specification [fmt] that it replaces.
       For instance, ["%( %i %)"] reads any format string that can read a value
       of type [int].
-      Returns the format string read, and the value read using the format
-      string read.
+      The conversion returns the format string read [rf], and then a value
+      read using [rf].
       Hence, if [s] is the string ["\"%4d\"1234.00"], then
       [Scanf.sscanf s "%(%i%)" (fun fmt i -> fmt, i)] evaluates to
       [("%4d", 1234)].
-      If the special flag [_] is used, the conversion discards the
-      format string read and only returns the value read with the format
-      string read.
-      Hence, if [s] is the string ["\"%4d\"1234.00"], then
-      [Scanf.sscanf s "%_(%i%)"] is simply equivalent to
-      [Scanf.sscanf "1234.00" "%4d"].
+
+      This behaviour is not mere format substitution, since the conversion
+      returns the format string read as additional argument. If you need
+      pure format substitution, use special flag [_] to discard the
+      extraneous argument: conversion [%_\( fmt %\)] reads a format string
+      [rf] and then behaves the same as format string [rf].  Hence, if [s] is
+      the string ["\"%4d\"1234.00"], then [Scanf.sscanf s "%_(%i%)"] is
+      simply equivalent to [Scanf.sscanf "1234.00" "%4d"].
+
     - [l]: returns the number of lines read so far.
     - [n]: returns the number of characters read so far.
     - [N] or [L]: returns the number of tokens read so far.
@@ -385,7 +401,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     analysis and parsing. If it appears not expressive enough for your
     needs, several alternative exists: regular expressions (module
     [Str]), stream parsers, [ocamllex]-generated lexers,
-    [ocamlyacc]-generated parsers. *)
+    [ocamlyacc]-generated parsers.
+*)
 
 (** {7:indication Scanning indications in format strings} *)
 
@@ -401,10 +418,10 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
 
     Note:
 
-    - As usual in format strings, [%] characters must be escaped using [%%]
-      and [%\@] is equivalent to [\@]; this rule still holds within range
-      specifications and scanning indications.
-      For instance, ["%s@%%"] reads a string up to the next [%] character.
+    - As usual in format strings, [%] and [\@] characters must be escaped
+    using [%%] and [%\@]; this rule still holds within range specifications
+    and scanning indications.
+    For instance, ["%s@%%"] reads a string up to the next [%] character.
     - The scanning indications introduce slight differences in the syntax of
     [Scanf] format strings, compared to those used for the [Printf]
     module. However, the scanning indications are similar to those used in
@@ -412,7 +429,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     by [!Scanf.bscanf], it is wise to use printing functions from the
     [Format] module (or, if you need to use functions from [Printf], banish
     or carefully double check the format strings that contain ['\@']
-    characters). *)
+    characters).
+*)
 
 (** {7 Exceptions during scanning} *)
 
@@ -433,7 +451,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     - as a consequence, scanning a [%s] conversion never raises exception
     [End_of_file]: if the end of input is reached the conversion succeeds and
     simply returns the characters read so far, or [""] if none were ever read.
-    *)
+*)
 
 (** {6 Specialised formatted input functions} *)
 
@@ -448,14 +466,16 @@ val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     position, and so on).
 
     As a consequence, never mix direct low level reading and high level
-    scanning from the same regular input channel. *)
+    scanning from the same regular input channel.
+*)
 
 val sscanf : string -> ('a, 'b, 'c, 'd) scanner;;
 (** Same as {!Scanf.bscanf}, but reads from the given string. *)
 
 val scanf : ('a, 'b, 'c, 'd) scanner;;
 (** Same as {!Scanf.bscanf}, but reads from the predefined formatted input
-    channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *)
+    channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin].
+*)
 
 val kscanf :
   Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) ->
@@ -464,7 +484,8 @@ val kscanf :
     [ef] that is called in case of error: if the scanning process or
     some conversion fails, the scanning function aborts and calls the
     error handling function [ef] with the formatted input channel and the
-    exception that aborted the scanning process as arguments. *)
+    exception that aborted the scanning process as arguments.
+*)
 
 (** {6 Reading format strings from input} *)
 
@@ -496,10 +517,10 @@ val format_from_string :
     @since 3.10.0
 *)
 
-val unescaped : string -> string
+val unescaped : string -> string;;
 (** Return a copy of the argument with escape sequences, following the
     lexical conventions of OCaml, replaced by their corresponding
-    special characters.  If there is no escape sequence in the
+    special characters. If there is no escape sequence in the
     argument, still return a copy, contrary to String.escaped.
     @since 4.00.0
 *)
diff --git a/stdlib/set.ml b/stdlib/set.ml
index 00dd7945..4e1f4be8 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: set.ml 12510 2012-05-30 11:28:51Z scherer $ *)
-
 (* Sets over ordered types *)
 
 module type OrderedType =
@@ -49,6 +47,7 @@ module type S =
     val max_elt: t -> elt
     val choose: t -> elt
     val split: elt -> t -> t * bool * t
+    val find: elt -> t -> elt
   end
 
 module Make(Ord: OrderedType) =
@@ -350,4 +349,10 @@ module Make(Ord: OrderedType) =
 
     let choose = min_elt
 
+    let rec find x = function
+        Empty -> raise Not_found
+      | 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)
   end
diff --git a/stdlib/set.mli b/stdlib/set.mli
index 19117b65..32adf1f2 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: set.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Sets over ordered types.
 
    This module implements the set data structure, given a total ordering
@@ -72,8 +70,8 @@ module type S =
     val inter: t -> t -> t
     (** Set intersection. *)
 
-    (** Set difference. *)
     val diff: t -> t -> t
+    (** Set difference. *)
 
     val compare: t -> t -> int
     (** Total ordering between sets. Can be used as the ordering function
@@ -145,6 +143,12 @@ module type S =
           strictly greater than [x];
           [present] is [false] if [s] contains no element equal to [x],
           or [true] if [s] contains an element equal to [x]. *)
+
+    val find: elt -> t -> elt
+    (** [find x s] returns the element of [s] equal to [x] (according
+        to [Ord.compare]), or raise [Not_found] if no such element
+        exists.
+        @since 4.01.0 *)
   end
 (** Output signature of the functor {!Set.Make}. *)
 
diff --git a/stdlib/sort.ml b/stdlib/sort.ml
index ac8b5119..59c76cb7 100644
--- a/stdlib/sort.ml
+++ b/stdlib/sort.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Merging and sorting *)
 
 open Array
diff --git a/stdlib/sort.mli b/stdlib/sort.mli
index 820f508b..d5abb79f 100644
--- a/stdlib/sort.mli
+++ b/stdlib/sort.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sort.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Sorting and merging lists.
 
    @deprecated This module is obsolete and exists only for backward
diff --git a/stdlib/stack.ml b/stdlib/stack.ml
index 75b397c2..4db3d5b4 100644
--- a/stdlib/stack.ml
+++ b/stdlib/stack.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stack.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type 'a t = { mutable c : 'a list }
 
 exception Empty
diff --git a/stdlib/stack.mli b/stdlib/stack.mli
index f9cb6398..9b468aa6 100644
--- a/stdlib/stack.mli
+++ b/stdlib/stack.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stack.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Last-in first-out stacks.
 
    This module implements stacks (LIFOs), with in-place modification.
diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml
index c0e2f0a7..35b25e0b 100644
--- a/stdlib/stdLabels.ml
+++ b/stdlib/stdLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stdLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [StdLabels]: meta-module for labelled libraries *)
 
 module Array = ArrayLabels
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index 0a3e1ced..bf9ef654 100644
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stdLabels.mli 12823 2012-08-06 11:41:12Z doligez $ *)
-
 (** Standard labeled libraries.
 
    This meta-module provides labelized version of the {!Array},
diff --git a/stdlib/std_exit.ml b/stdlib/std_exit.ml
index 68d8b0fb..66d49c99 100644
--- a/stdlib/std_exit.ml
+++ b/stdlib/std_exit.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: std_exit.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Ensure that [at_exit] functions are called at the end of every program *)
 
 let _ = do_at_exit()
diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib
index 803c9523..b41bc2d9 100644
--- a/stdlib/stdlib.mllib
+++ b/stdlib/stdlib.mllib
@@ -1,7 +1,6 @@
 # This file lists all standard library modules
 # (in the same order as Makefile.shared).
 # It is used in particular to know what to expunge in toplevels.
-# $Id: stdlib.mllib 9540 2010-01-20 16:26:46Z doligez $
 
 Pervasives
 Array
diff --git a/stdlib/stream.ml b/stdlib/stream.ml
index f63f31cb..753bce00 100644
--- a/stdlib/stream.ml
+++ b/stdlib/stream.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stream.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* The fields of type t are not mutable to preserve polymorphism of
    the empty stream. This is type safe because the empty stream is never
    patched. *)
@@ -21,8 +19,8 @@ type 'a t = { count : int; data : 'a data }
 and 'a data =
     Sempty
   | Scons of 'a * 'a data
-  | Sapp of 'a data * 'a t
-  | Slazy of 'a t Lazy.t
+  | Sapp of 'a data * 'a data
+  | Slazy of 'a data Lazy.t
   | Sgen of 'a gen
   | Sbuffio of buffio
 and 'a gen = { mutable curr : 'a option option; func : int -> 'a option }
@@ -42,37 +40,26 @@ let fill_buff b =
   b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0
 ;;
 
-let rec get_data s d = match d with
- (* Only return a "forced stream", that is either Sempty or
-    Scons(a,_). If d is a generator or a buffer, the item a is seen as
-    extracted from the generator/buffer.
-
-    Forcing also updates the "count" field of the delayed stream,
-    in the Sapp and Slazy cases (see slazy/lapp implementation below). *)
+let rec get_data count d = match d with
+ (* Returns either Sempty or Scons(a, _) even when d is a generator
+    or a buffer. In those cases, the item a is seen as extracted from
+ the generator/buffer.
+ The count parameter is used for calling `Sgen-functions'.  *)
    Sempty | Scons (_, _) -> d
- | Sapp (d1, s2) ->
-     begin match get_data s d1 with
-       Scons (a, d11) -> Scons (a, Sapp (d11, s2))
-     | Sempty ->
-       set_count s s2.count;
-       get_data s s2.data
+ | Sapp (d1, d2) ->
+     begin match get_data count d1 with
+       Scons (a, d11) -> Scons (a, Sapp (d11, d2))
+     | Sempty -> get_data count d2
      | _ -> assert false
      end
- | Sgen {curr = Some None; _ } -> Sempty
- | Sgen ({curr = Some(Some a); _ } as g) ->
+ | Sgen {curr = Some None; func = _ } -> Sempty
+ | Sgen ({curr = Some(Some a); func = f} as g) ->
      g.curr <- None; Scons(a, d)
- | Sgen ({curr = None; _} as g) ->
-     (* Warning: anyone using g thinks that an item has been read *)
-     begin match g.func s.count with
+ | Sgen g ->
+     begin match g.func count with
        None -> g.curr <- Some(None); Sempty
-     | Some a ->
-       (* One must not update g.curr here, because there Scons(a,d)
-          result of get_data, if the outer stream s was a Sapp, will
-          be used to update the outer stream to Scons(a,s): there is
-          already a memoization process at the outer layer. If g.curr
-          was updated here, the saved element would be produced twice,
-          once by the outer layer, once by Sgen/g.curr. *)
-       Scons(a, d)
+     | Some a -> Scons(a, d)
+         (* Warning: anyone using g thinks that an item has been read *)
      end
  | Sbuffio b ->
      if b.ind >= b.len then fill_buff b;
@@ -80,10 +67,7 @@ let rec get_data s d = match d with
        let r = Obj.magic (String.unsafe_get b.buff b.ind) in
        (* Warning: anyone using g thinks that an item has been read *)
        b.ind <- succ b.ind; Scons(r, d)
- | Slazy f ->
-   let s2 = Lazy.force f in
-   set_count s s2.count;
-   get_data s s2.data
+ | Slazy f -> get_data count (Lazy.force f)
 ;;
 
 let rec peek s =
@@ -92,20 +76,14 @@ let rec peek s =
    Sempty -> None
  | Scons (a, _) -> Some a
  | Sapp (_, _) ->
-     begin match get_data s s.data with
-     | Scons(a, _) as d -> set_data s d; Some a
+     begin match get_data s.count s.data with
+       Scons(a, _) as d -> set_data s d; Some a
      | Sempty -> None
      | _ -> assert false
      end
- | Slazy f ->
-   let s2 = Lazy.force f in
-   set_count s s2.count;
-   set_data s s2.data;
-   peek s
- | Sgen {curr = Some a; _ } -> a
- | Sgen ({curr = None; _ } as g) ->
-     let x = g.func s.count in
-     g.curr <- Some x; x
+ | Slazy f -> set_data s (Lazy.force f); peek s
+ | Sgen {curr = Some a} -> a
+ | Sgen g -> let x = g.func s.count in g.curr <- Some x; x
  | Sbuffio b ->
      if b.ind >= b.len then fill_buff b;
      if b.len == 0 then begin set_data s Sempty; None end
@@ -167,7 +145,18 @@ let of_list l =
 ;;
 
 let of_string s =
-  from (fun c -> if c < String.length s then Some s.[c] else None)
+  let count = ref 0 in
+  from (fun _ ->
+    (* We cannot use the index passed by the [from] function directly
+       because it returns the current stream count, with absolutely no
+       guarantee that it will start from 0. For example, in the case
+       of [Stream.icons 'c' (Stream.from_string "ab")], the first
+       access to the string will be made with count [1] already.
+    *)
+    let c = !count in
+    if c < String.length s
+    then (incr count; Some s.[c])
+    else None)
 ;;
 
 let of_channel ic =
@@ -177,21 +166,18 @@ let of_channel ic =
 
 (* Stream expressions builders *)
 
-(* In the slazy and lapp case, we can't statically predict the value
-   of the "count" field. We put a dummy 0 value, which will be updated
-   when the parameter stream is forced (see update code in [get_data]
-   and [peek]). *)
-
+let iapp i s = {count = 0; data = Sapp (i.data, s.data)};;
+let icons i s = {count = 0; data = Scons (i, s.data)};;
 let ising i = {count = 0; data = Scons (i, Sempty)};;
-let icons i s = {count = s.count - 1; data = Scons (i, s.data)};;
-let iapp i s = {count = i.count; data = Sapp (i.data, s)};;
 
-let sempty = {count = 0; data = Sempty};;
-let slazy f = {count = 0; data = Slazy (lazy (f()))};;
+let lapp f s =
+  {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))}
+;;
+let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};;
+let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};;
 
-let lsing f = {count = 0; data = Slazy (lazy (ising (f())))};;
-let lcons f s = {count = 0; data = Slazy (lazy (icons (f()) s))};;
-let lapp f s = {count = 0; data = Slazy (lazy(iapp (f()) s))};;
+let sempty = {count = 0; data = Sempty};;
+let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};;
 
 (* For debugging use *)
 
@@ -211,11 +197,11 @@ and dump_data f =
       print_string ", ";
       dump_data f d;
       print_string ")"
-  | Sapp (d1, s2) ->
+  | Sapp (d1, d2) ->
       print_string "Sapp (";
       dump_data f d1;
       print_string ", ";
-      dump f s2;
+      dump_data f d2;
       print_string ")"
   | Slazy _ -> print_string "Slazy"
   | Sgen _ -> print_string "Sgen"
diff --git a/stdlib/stream.mli b/stdlib/stream.mli
index aa697e3d..aeb0da1e 100644
--- a/stdlib/stream.mli
+++ b/stdlib/stream.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stream.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** Streams and parsers. *)
 
 type 'a t
@@ -34,7 +32,12 @@ val from : (int -> 'a option) -> 'a t
    To create a new stream element, the function [f] is called with
    the current stream count. The user function [f] must return either
    [Some ] for a value or [None] to specify the end of the
-   stream. *)
+   stream.
+
+   Do note that the indices passed to [f] may not start at [0] in the
+   general case. For example, [[< '0; '1; Stream.from f >]] would call
+   [f] the first time with count [2].
+*)
 
 val of_list : 'a list -> 'a t
 (** Return the stream holding the elements of the list in the same
diff --git a/stdlib/string.ml b/stdlib/string.ml
index b82e7fa4..fda40b52 100644
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: string.ml 12210 2012-03-08 19:52:03Z doligez $ *)
-
 (* String operations *)
 
 external length : string -> int = "%string_length"
diff --git a/stdlib/string.mli b/stdlib/string.mli
index 8cbc8275..14f2c82d 100644
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: string.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** String operations.
 
   Given a string [s] of length [l], we call character number in [s]
diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
index 210fb24d..415dbff5 100644
--- a/stdlib/stringLabels.ml
+++ b/stdlib/stringLabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stringLabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Module [StringLabels]: labelled String module *)
 
 include String
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index faa9a952..8e2e6d37 100644
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stringLabels.mli 12241 2012-03-14 14:32:07Z doligez $ *)
-
 (** String operations. *)
 
 external length : string -> int = "%string_length"
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index 06fc6923..944b1090 100644
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sys.mli 12212 2012-03-08 22:27:57Z doligez $ *)
-
 (** System interface. *)
 
 val argv : string array
@@ -80,6 +78,18 @@ val os_type : string
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
 -  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
+val unix : bool
+(** True if [Sys.os_type = "Unix"].
+    @since 4.01.0 *)
+
+val win32 : bool
+(** True if [Sys.os_type = "Win32"].
+    @since 4.01.0 *)
+
+val cygwin : bool
+(** True if [Sys.os_type = "Cygwin"].
+    @since 4.01.0 *)
+
 val word_size : int
 (** Size of one word on the machine currently executing the OCaml
    program, in bits: 32 or 64. *)
@@ -103,7 +113,7 @@ val max_array_length : int
 type signal_behavior =
     Signal_default
   | Signal_ignore
-  | Signal_handle of (int -> unit)
+  | Signal_handle of (int -> unit)   (** *)
 (** What to do when receiving a signal:
    - [Signal_default]: take the default behavior
      (usually: abort the program)
diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
index 8784a985..c54fcb82 100644
--- a/stdlib/sys.mlp
+++ b/stdlib/sys.mlp
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sys.mlp 12210 2012-03-08 19:52:03Z doligez $ *)
-
 (* WARNING: sys.ml is generated from sys.mlp.  DO NOT EDIT sys.ml or
    your changes will be lost.
 *)
@@ -21,9 +19,19 @@
 
 external get_config: unit -> string * int * bool = "caml_sys_get_config"
 external get_argv: unit -> string * string array = "caml_sys_get_argv"
+external big_endian : unit -> bool = "%big_endian"
+external word_size : unit -> int = "%word_size"
+external unix : unit -> bool = "%ostype_unix"
+external win32 : unit -> bool = "%ostype_win32"
+external cygwin : unit -> bool = "%ostype_cygwin"
 
 let (executable_name, argv) = get_argv()
-let (os_type, word_size, big_endian) = get_config()
+let (os_type, _, _) = get_config()
+let big_endian = big_endian ()
+let word_size = word_size ()
+let unix = unix ()
+let win32 = win32 ()
+let cygwin = cygwin ()
 let max_array_length = (1 lsl (word_size - 10)) - 1;;
 let max_string_length = word_size / 8 * max_array_length - 1;;
 
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index 9b9c64cf..536a42e0 100644
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: weak.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Weak array operations *)
 
 type 'a t;;
@@ -209,7 +207,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
         t.hashes.(index) <- newhashes;
         if sz <= t.limit && newsz > t.limit then begin
           t.oversize <- t.oversize + 1;
-          for i = 0 to over_limit do test_shrink_bucket t done;
+          for _i = 0 to over_limit do test_shrink_bucket t done;
         end;
         if t.oversize > Array.length t.table / over_limit then resize t;
       end else if check bucket i then begin
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 599ab60e..a27dea5c 100644
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: weak.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Arrays of weak pointers and hash tables of weak pointers. *)
 
 
diff --git a/testsuite/Makefile b/testsuite/Makefile
index d454f53d..e84d826c 100644
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -1,37 +1,63 @@
-# $Id: Makefile 12579 2012-06-06 15:46:37Z doligez $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
 BASEDIR=${PWD}
-NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-print-directory' || echo ''`
+NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 && echo '--no-print-directory'`
 
+FIND=find
+include ../config/Makefile
+
+.PHONY: default
 default:
 	@echo "Available targets:"
-	@echo "  all             launches all tests"
-	@echo "  list FILE=f     launches the tests referenced in file f (one path per line)"
-	@echo "  one DIR=p       launches the tests located in path p"
-	@echo "  promote DIR=p   promotes the reference files for the tests located in path p"
-	@echo "  lib             builds library modules"
-	@echo "  clean           deletes generated files"
-	@echo "  report          prints the report for the last execution, if any"
+	@echo "  all             launch all tests"
+	@echo "  list FILE=f     launch the tests referenced in file f (one path per line)"
+	@echo "  one DIR=p       launch the tests located in path p"
+	@echo "  promote DIR=p   promote the reference files for the tests located in path p"
+	@echo "  lib             build library modules"
+	@echo "  clean           delete generated files"
+	@echo "  report          print the report for the last execution, if any"
 
+.PHONY: all
 all: lib
 	@for dir in tests/*; do \
 	  $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
 	done 2>&1 | tee _log
 	@$(MAKE) report
 
+.PHONY: list
 list: lib
-	@if [ -z $(FILE) ]; then echo "No value set for variable 'FILE'."; exit 1; fi
-	@if [ ! -f $(FILE) ]; then echo "File '$(FILE)' does not exist."; exit 1; fi
+	@if [ -z "$(FILE)" ]; \
+	  then echo "No value set for variable 'FILE'."; \
+	  exit 1; \
+	fi
 	@while read LINE; do \
 	  $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \
-	done < $(FILE) 2>&1 | tee _log
+	done <$(FILE) 2>&1 | tee _log
 	@$(MAKE) report
 
+.PHONY: one
 one: lib
-	@if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi
-	@if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi
+	@if [ -z "$(DIR)" ]; then \
+	  echo "No value set for variable 'DIR'."; \
+	  exit 1; \
+	fi
+	@if [ ! -d $(DIR) ]; then \
+	  echo "Directory '$(DIR)' does not exist."; \
+	  exit 1; \
+	fi
 	@$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
 
+.PHONY: exec-one
 exec-one:
 	@if [ ! -f $(DIR)/Makefile ]; then \
 	  for dir in $(DIR)/*; do \
@@ -39,35 +65,39 @@ exec-one:
 	      $(MAKE) exec-one DIR=$$dir; \
 	    fi; \
 	  done; \
-        else \
+	else \
 	  echo "Running tests from '$$DIR' ..."; \
-	  (cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR)); \
+	  cd $(DIR) && \
+	  $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \
 	fi
 
-promote: FORCE
-	@if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi
-	@if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi
-	@(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote)
+.PHONY: promote
+promote:
+	@if [ -z "$(DIR)" ]; then \
+	  echo "No value set for variable 'DIR'."; \
+	  exit 1; \
+	fi
+	@if [ ! -d $(DIR) ]; then \
+	  echo "Directory '$(DIR)' does not exist."; \
+	  exit 1; \
+	fi
+	@cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote
 
-lib: FORCE
-	@(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR))
+.PHONY: lib
+lib:
+	@cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
 
-clean: FORCE
-	@(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean)
-	@for file in `find interactive tests -name Makefile`; do \
+.PHONY: clean
+clean:
+	@cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
+	@for file in `$(FIND) interactive tests -name Makefile`; do \
 	  (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
 	done
 
-report: FORCE
+.PHONY: report
+report:
 	@if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi
-	@echo ''
-	@echo 'Summary:'
-	@echo '  ' `grep 'passed$$' _log | wc -l` 'test(s) passed'
-	@echo '  ' `grep 'failed$$' _log | wc -l` 'test(s) failed'
-	@echo '  ' `grep '^Error' _log | wc -l` 'compilation error(s)'
-	@echo '  ' `grep '^Warning' _log | wc -l` 'compilation warning(s)'
-	@echo '  ' `grep '^make\[2\]: ' _log | wc -l` 'makefile error(s)'
-
-empty: FORCE
+	@awk -f makefiles/summarize.awk <_log
 
-FORCE:
+.PHONY: empty
+empty:
diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore
new file mode 100644
index 00000000..a65ca6ca
--- /dev/null
+++ b/testsuite/external/.ignore
@@ -0,0 +1,146 @@
+*.tar.gz
+*.tar.bz2
+*.tgz
+*.tbz
+*.zip
+
+log-*
+log_*
+
+advi
+advi-1.10.2
+altergo
+alt-ergo-0.95
+binprot
+bin_prot-109.30.00
+bitstring
+ocaml-bitstring-2.0.3
+boomerang
+boomerang-0.2
+calendar
+calendar-2.03.2
+camlimages
+camlimages-4.0.1
+camlpdf
+camlpdf-0.5
+camlp5
+camlp5-6.10
+camlzip
+camlzip-1.04
+camomile
+camomile-0.8.4
+comparelib
+comparelib-109.15.00
+compcert
+compcert-1.13
+configfile
+config-file-1.1
+coq
+coq-8.4pl1
+core
+core-109.37.00
+coreextended
+core_extended-109.36.00
+corekernel
+core_kernel-109.37.00
+cryptokit
+cryptokit-1.6
+customprintf
+custom_printf-109.27.00
+dbm
+camldbm-1.0
+expect
+ocaml-expect-0.0.3
+extlib
+extlib-1.5.2
+fieldslib
+fieldslib-109.15.00
+fileutils
+ocaml-fileutils-0.4.4
+findlib
+findlib-1.3.3
+framac
+frama-c-Oxygen-20120901
+geneweb
+gw-6.05-src
+herelib
+herelib-109.35.00
+hevea
+hevea-2.09
+kaputt
+kaputt-1.2
+lablgtk
+lablgtk-2.16.0
+lablgtkextras
+lablgtkextras-1.3
+lwt
+lwt-2.4.0
+menhir
+menhir-20120123
+mldonkey
+mldonkey-3.1.2
+mysql
+ocaml-mysql-1.0.4
+oasis
+oasis-0.3.0
+obrowser
+obrowser-1.1.1
+ocamlgraph
+ocamlgraph-1.8.2
+ocamlify
+ocamlify-0.0.1
+ocamlmod
+ocamlmod-0.0.3
+ocamlnet
+ocamlnet-3.5.1
+ocamlscript
+ocamlscript-2.0.3
+ocamlssl
+ocaml-ssl-0.4.6
+ocamltext
+ocaml-text-0.5
+ocgi
+ocgi-0.5
+ocsigen
+ocsigen-bundle-2.2.2
+odn
+ocaml-data-notation-0.0.10
+omake
+omake-0.9.8.6
+ounit
+ounit-1.1.2
+paounit
+pa_ounit-109.36.00
+pcre
+pcre-ocaml-6.2.5
+pipebang
+pipebang-109.28.00
+react
+react-0.9.3
+res
+res-3.2.0
+rss
+ocamlrss-2.2.2
+sexplib
+sexplib-109.15.00
+sks
+sks-1.1.3
+sqlite
+sqlite3-ocaml-2.0.1
+textutils
+textutils-109.36.00
+typeconv
+type_conv-109.28.00
+unison
+unison-2.45.4
+variantslib
+variantslib-109.15.00
+vsyml
+vsyml-2010-04-06
+xmllight
+xml-light-2.2
+xmlm
+xmlm-1.1.0
+zen
+zen_2.3.2
+._ZEN_2.3.2
diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile
new file mode 100644
index 00000000..5fcd005b
--- /dev/null
+++ b/testsuite/external/Makefile
@@ -0,0 +1,1676 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#           Damien Doligez, projet Gallium, INRIA Rocquencourt          #
+#                                                                       #
+#   Copyright 2012 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# To use this test set, you need OCaml installed in a directory where
+# you have write rights.
+
+# Warning: use of this Makefile will install lots of software
+# in the same place where OCaml is installed.
+
+# It is recommended that you install OCaml in some isolated
+# directory D (for example /usr/local/ocaml/test), add D/bin
+# at the front of your PATH, then use this Makefile to test
+# your OCaml installation.
+
+WGET = wget --no-check-certificate --progress=dot:mega
+
+PREFIX = "`ocamlc -where | sed -e 's|/[^/]*/[^/]*$$||'`"
+VERSION = `ocamlc -vnum`
+
+.PHONY: default
+default:
+	@printf "\n\n########## Starting make at " >>log-${VERSION}
+	@date >>log-${VERSION}
+	${MAKE} platform >>log-${VERSION} 2>&1
+	@printf '\n'
+	mv log-${VERSION} log_${VERSION}_`date -u '+%Y-%m-%d:%H:%M:%S'`
+
+# Platform-dependent subsets: add your own here.
+
+.PHONY: all-cygwin
+all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \
+            sqlite ocgi xmllight configfile xmlm omake \
+            camomile zen vsyml extlib fileutils ocamlify ocamlmod \
+            calendar dbm ocamlscript camlp5 geneweb coq
+
+all-macos: findlib lablgtk ocamlgraph ounit res pcre core react ocamltext \
+           ocamlssl lwt camlzip cryptokit sqlite menhir obrowser hevea \
+           unison ocgi xmllight configfile xmlm lablgtkextras sks omake \
+           altergo boomerang camomile zen vsyml ocamlnet extlib fileutils \
+           odn ocamlify expect ocamlmod oasis calendar camlimages advi \
+           dbm ocsigen ocamlscript camlp5 geneweb coq framac
+
+platform:
+	case `uname -s` in \
+	  CYGWIN*) ${MAKE} all-cygwin;; \
+	  Darwin) ${MAKE} all-macos;; \
+	  *) ${MAKE} all;; \
+	esac
+
+# http://projects.camlcity.org/projects/findlib.html
+FINDLIB=findlib-1.3.3
+${FINDLIB}.tar.gz:
+	${WGET} http://download.camlcity.org/download/$@
+findlib: ${FINDLIB}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${FINDLIB}
+	tar zxf ${FINDLIB}.tar.gz
+	./Patcher.sh ${FINDLIB}
+	( cd ${FINDLIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure && \
+	  ${MAKE} all && \
+	  ${MAKE} opt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${FINDLIB} findlib
+distclean::
+	rm -f ${FINDLIB}.tar.gz
+all: findlib
+
+# http://lablgtk.forge.ocamlcore.org/
+LABLGTK=lablgtk-2.16.0
+${LABLGTK}.tar.gz:
+	${WGET} https://forge.ocamlcore.org/frs/download.php/561/$@
+lablgtk: ${LABLGTK}.tar.gz findlib # TODO: add lablgl
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${LABLGTK}
+	tar zxf ${LABLGTK}.tar.gz
+	./Patcher.sh ${LABLGTK}
+	( cd ${LABLGTK} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure -prefix ${PREFIX} && \
+	  ${MAKE} world && \
+	  ocamlfind remove lablgtk2 && \
+	  ${MAKE} install && \
+	  rm -f ${PREFIX}/lib/ocaml/lablgtk2 && \
+	  ln -f -s ${PREFIX}/lib/ocaml/site-lib/lablgtk2 \
+	           ${PREFIX}/lib/ocaml/lablgtk2 )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${LABLGTK} lablgtk
+distclean::
+	rm -f ${LABLGTK}.tar.gz
+all: lablgtk
+
+# http://ocamlgraph.lri.fr/
+OCAMLGRAPH=ocamlgraph-1.8.2
+${OCAMLGRAPH}.tar.gz:
+	${WGET} http://ocamlgraph.lri.fr/download/$@
+ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib lablgtk
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLGRAPH}
+	tar zxf ${OCAMLGRAPH}.tar.gz
+	./Patcher.sh ${OCAMLGRAPH}
+	( cd ${OCAMLGRAPH} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure -prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  rm -rf ${PREFIX}/lib/ocaml/ocamlgraph && \
+	  ocamlfind remove ocamlgraph && \
+	  ${MAKE} install install-findlib && \
+	  ln -s ${PREFIX}/lib/ocaml/site-lib/ocamlgraph \
+	        ${PREFIX}/lib/ocaml/ocamlgraph )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLGRAPH} ocamlgraph
+distclean::
+	rm -f ${OCAMLGRAPH}.tar.gz
+all: ocamlgraph
+
+# http://ounit.forge.ocamlcore.org/
+OUNIT=ounit-1.1.2
+${OUNIT}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/886/$@
+ounit: ${OUNIT}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OUNIT}
+	tar zxf ${OUNIT}.tar.gz
+	./Patcher.sh ${OUNIT}
+	( cd ${OUNIT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} && \
+	  ocamlfind remove oUnit && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OUNIT} ounit
+distclean::
+	rm -f ${OUNIT}.tar.gz
+all: ounit
+
+# https://bitbucket.org/mmottl/res
+RES=res-3.2.0
+${RES}.tar.gz:
+	${WGET} https://bitbucket.org/mmottl/res/downloads/$@
+res: ${RES}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${RES}
+	tar zxf ${RES}.tar.gz
+	./Patcher.sh ${RES}
+	( cd ${RES} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} && \
+	  ocamlfind remove res && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${RES} res
+distclean::
+	rm -f ${RES}.tar.gz
+all: res
+
+# https://bitbucket.org/mmottl/pcre-ocaml
+PCRE=pcre-ocaml-6.2.5
+${PCRE}.tar.gz:
+	${WGET} https://bitbucket.org/mmottl/pcre-ocaml/downloads/$@
+pcre: ${PCRE}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${PCRE}
+	tar zxf ${PCRE}.tar.gz
+	./Patcher.sh ${PCRE}
+	( cd ${PCRE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} && \
+	  ocamlfind remove pcre && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${PCRE} pcre
+distclean::
+	rm -f ${PCRE}.tar.gz
+all: pcre
+
+###########################################################################
+
+## Jane Street Core
+
+# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/
+TYPECONV=type_conv-109.28.00
+${TYPECONV}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@
+typeconv: ${TYPECONV}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${TYPECONV}
+	tar zxf ${TYPECONV}.tar.gz
+	./Patcher.sh ${TYPECONV}
+	( cd ${TYPECONV} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove type_conv && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${TYPECONV} typeconv
+distclean::
+	rm -f ${TYPECONV}.tar.gz
+all: typeconv
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+VARIANTSLIB=variantslib-109.15.00
+${VARIANTSLIB}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+variantslib: ${VARIANTSLIB}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${VARIANTSLIB}
+	tar zxf ${VARIANTSLIB}.tar.gz
+	./Patcher.sh ${VARIANTSLIB}
+	( cd ${VARIANTSLIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove variantslib && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${VARIANTSLIB} variantslib
+distclean::
+	rm -f ${VARIANTSLIB}.tar.gz
+all: variantslib
+
+# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/
+PIPEBANG=pipebang-109.28.00
+${PIPEBANG}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@
+pipebang: ${PIPEBANG}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${PIPEBANG}
+	tar zxf ${PIPEBANG}.tar.gz
+	./Patcher.sh ${PIPEBANG}
+	( cd ${PIPEBANG} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove pa_pipebang && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${PIPEBANG} pipebang
+distclean::
+	rm -f ${PIPEBANG}.tar.gz
+all: pipebang
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+PAOUNIT=pa_ounit-109.36.00
+${PAOUNIT}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+paounit: ${PAOUNIT}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${PAOUNIT}
+	tar zxf ${PAOUNIT}.tar.gz
+	./Patcher.sh ${PAOUNIT}
+	( cd ${PAOUNIT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove pa_ounit && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${PAOUNIT} paounit
+distclean::
+	rm -f ${PAOUNIT}.tar.gz
+all: paounit
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+COMPARELIB=comparelib-109.15.00
+${COMPARELIB}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+comparelib: ${COMPARELIB}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${COMPARELIB}
+	tar zxf ${COMPARELIB}.tar.gz
+	./Patcher.sh ${COMPARELIB}
+	( cd ${COMPARELIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove comparelib && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${COMPARELIB} comparelib
+distclean::
+	rm -f ${COMPARELIB}.tar.gz
+all: comparelib
+
+# https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/
+BINPROT=bin_prot-109.30.00
+${BINPROT}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/$@
+binprot: ${BINPROT}.tar.gz findlib typeconv ounit
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${BINPROT}
+	tar zxf ${BINPROT}.tar.gz
+	./Patcher.sh ${BINPROT}
+	( cd ${BINPROT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove bin_prot && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${BINPROT} binprot
+distclean::
+	rm -f ${BINPROT}.tar.gz
+all: binprot
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+FIELDSLIB=fieldslib-109.15.00
+${FIELDSLIB}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+fieldslib: ${FIELDSLIB}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${FIELDSLIB}
+	tar zxf ${FIELDSLIB}.tar.gz
+	./Patcher.sh ${FIELDSLIB}
+	( cd ${FIELDSLIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove fieldslib && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${FIELDSLIB} fieldslib
+distclean::
+	rm -f ${FIELDSLIB}.tar.gz
+all: fieldslib
+
+# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/
+SEXPLIB=sexplib-109.15.00
+${SEXPLIB}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@
+sexplib: ${SEXPLIB}.tar.gz findlib typeconv
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${SEXPLIB}
+	tar zxf ${SEXPLIB}.tar.gz
+	./Patcher.sh ${SEXPLIB}
+	( cd ${SEXPLIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove sexplib && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${SEXPLIB} sexplib
+distclean::
+	rm -f ${SEXPLIB}.tar.gz
+all: sexplib
+
+# https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/
+HERELIB=herelib-109.35.00
+${HERELIB}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/$@
+herelib: ${HERELIB}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${HERELIB}
+	tar zxf ${HERELIB}.tar.gz
+	./Patcher.sh ${HERELIB}
+	( cd ${HERELIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove herelib && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${HERELIB} herelib
+distclean::
+	rm -f ${HERELIB}.tar.gz
+all: herelib
+
+# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/
+COREKERNEL=core_kernel-109.37.00
+${COREKERNEL}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@
+corekernel: ${COREKERNEL}.tar.gz findlib variantslib sexplib fieldslib \
+      binprot comparelib paounit pipebang res ounit herelib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${COREKERNEL}
+	tar zxf ${COREKERNEL}.tar.gz
+	./Patcher.sh ${COREKERNEL}
+	( cd ${COREKERNEL} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove core_kernel && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${COREKERNEL} corekernel
+distclean::
+	rm -f ${COREKERNEL}.tar.gz
+all: core
+
+# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/
+CORE=core-109.37.00
+${CORE}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@
+core: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \
+      paounit pipebang res ounit corekernel
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CORE}
+	tar zxf ${CORE}.tar.gz
+	./Patcher.sh ${CORE}
+	( cd ${CORE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove core && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CORE} core
+distclean::
+	rm -f ${CORE}.tar.gz
+all: core
+
+# https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/
+CUSTOMPRINTF=custom_printf-109.27.00
+${CUSTOMPRINTF}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/$@
+customprintf: ${CUSTOMPRINTF}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CUSTOMPRINTF}
+	tar zxf ${CUSTOMPRINTF}.tar.gz
+	./Patcher.sh ${CUSTOMPRINTF}
+	( cd ${CUSTOMPRINTF} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove customprintf && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CUSTOMPRINTF} customprintf
+distclean::
+	rm -f ${CUSTOMPRINTF}.tar.gz
+all: customprintf
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+TEXTUTILS=textutils-109.36.00
+${TEXTUTILS}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+textutils: ${TEXTUTILS}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${TEXTUTILS}
+	tar zxf ${TEXTUTILS}.tar.gz
+	./Patcher.sh ${TEXTUTILS}
+	( cd ${TEXTUTILS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove textutils && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${TEXTUTILS} textutils
+distclean::
+	rm -f ${TEXTUTILS}.tar.gz
+all: textutils
+
+# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/
+COREEXTENDED=core_extended-109.36.00
+${COREEXTENDED}.tar.gz:
+	${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@
+coreextended: ${COREEXTENDED}.tar.gz findlib sexplib fieldslib binprot paounit \
+              pipebang core pcre res comparelib ounit
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${COREEXTENDED}
+	tar zxf ${COREEXTENDED}.tar.gz
+	./Patcher.sh ${COREEXTENDED}
+	( cd ${COREEXTENDED} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${COREEXTENDED} coreextended
+distclean::
+	rm -f ${COREEXTENDED}.tar.gz
+all: coreextended
+
+###########################################################################
+
+# http://erratique.ch/software/react
+REACT=react-0.9.3
+${REACT}.tbz:
+	${WGET} http://erratique.ch/software/react/releases/$@
+react: ${REACT}.tbz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${REACT}
+	tar jxf ${REACT}.tbz
+	./Patcher.sh ${REACT} oasis-common.patch
+	( cd ${REACT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ./test.native && \
+	  ocamlfind remove react && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${REACT} react
+distclean::
+	rm -f ${REACT}.tbz
+all: react
+
+# http://forge.ocamlcore.org/projects/ocaml-text/
+OCAMLTEXT=ocaml-text-0.5
+${OCAMLTEXT}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/641/$@
+ocamltext: ${OCAMLTEXT}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLTEXT}
+	tar zxf ${OCAMLTEXT}.tar.gz
+	./Patcher.sh ${OCAMLTEXT} oasis-common.patch
+	( cd ${OCAMLTEXT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} build && \
+	  ${MAKE} test && \
+	  ocamlfind remove text && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLTEXT} ocamltext
+distclean::
+	rm -f ${OCAMLTEXT}.tar.gz
+all: ocamltext
+
+# http://sourceforge.net/projects/savonet/files/ocaml-ssl/
+OCAMLSSL=ocaml-ssl-0.4.6
+${OCAMLSSL}.tar.gz:
+	${WGET} http://voxel.dl.sourceforge.net/project/savonet/ocaml-ssl/0.4.6/$@
+ocamlssl: ${OCAMLSSL}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLSSL}
+	tar zxf ${OCAMLSSL}.tar.gz
+	./Patcher.sh ${OCAMLSSL}
+	( cd ${OCAMLSSL} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure && \
+	  ${MAKE} && \
+	  ocamlfind remove ssl && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLSSL} ocamlssl
+distclean::
+	rm -f ${OCAMLSSL}.tar.gz
+all: ocamlssl
+
+# http://ocsigen.org/lwt/install
+LWT=lwt-2.4.0
+${LWT}.tar.gz:
+	${WGET} http://ocsigen.org/download/$@
+lwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl lablgtk
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${LWT}
+	tar zxf ${LWT}.tar.gz
+	./Patcher.sh ${LWT}
+	( cd ${LWT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  export C_INCLUDE_PATH=/usr/include:/opt/local/include && \
+	  export LIBRARY_PATH=/usr/lib:/opt/local/lib && \
+	  ./configure --enable-ssl --enable-react && \
+	  ${MAKE} && \
+	  ocamlfind remove lwt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${LWT} lwt
+distclean::
+	rm -f ${LWT}.tar.gz
+all: lwt
+
+# http://forge.ocamlcore.org/projects/camlzip/
+CAMLZIP=camlzip-1.04
+${CAMLZIP}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/328/$@
+camlzip: ${CAMLZIP}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CAMLZIP}
+	tar zxf ${CAMLZIP}.tar.gz
+	./Patcher.sh ${CAMLZIP}
+	( cd ${CAMLZIP} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} all && \
+	  ${MAKE} allopt && \
+	  ${MAKE} install && \
+	  ${MAKE} installopt && \
+	  ocamlfind remove camlzip && \
+	  ocamlfind install camlzip META )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CAMLZIP} camlzip
+distclean::
+	rm -f ${CAMLZIP}.tar.gz
+all: camlzip
+
+# http://forge.ocamlcore.org/projects/cryptokit/
+CRYPTOKIT=cryptokit-1.6
+${CRYPTOKIT}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/891/$@
+cryptokit: ${CRYPTOKIT}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CRYPTOKIT}
+	tar zxf ${CRYPTOKIT}.tar.gz
+	./Patcher.sh ${CRYPTOKIT}
+	( cd ${CRYPTOKIT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} build && \
+	  ${MAKE} test && \
+	  ocamlfind remove cryptokit && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CRYPTOKIT} cryptokit
+distclean::
+	rm -f ${CRYPTOKIT}.tar.gz
+all: cryptokit
+
+# https://bitbucket.org/mmottl
+SQLITE=sqlite3-ocaml-2.0.1
+${SQLITE}.tar.gz:
+	${WGET} https://bitbucket.org/mmottl/sqlite3-ocaml/downloads/$@
+sqlite: ${SQLITE}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${SQLITE}
+	tar zxf ${SQLITE}.tar.gz
+	./Patcher.sh ${SQLITE} oasis-common.patch
+	( cd ${SQLITE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove sqlite3 && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${SQLITE} sqlite
+distclean::
+	rm -f ${SQLITE}.tar.gz
+all: sqlite
+
+# http://gallium.inria.fr/~fpottier/menhir/
+MENHIR=menhir-20120123
+${MENHIR}.tar.gz:
+	${WGET} http://gallium.inria.fr/~fpottier/menhir/$@
+menhir: ${MENHIR}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${MENHIR}
+	tar zxf ${MENHIR}.tar.gz
+	./Patcher.sh ${MENHIR}
+	( cd ${MENHIR} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} PREFIX=${PREFIX} && \
+	  ocamlfind remove MenhirLib && \
+	  ${MAKE} PREFIX=${PREFIX} install)
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${MENHIR} menhir
+distclean::
+	rm -f ${MENHIR}.tar.gz
+all: menhir
+
+# http://ocsigen.org/obrowser/install
+OBROWSER=obrowser-1.1.1
+${OBROWSER}.tar.gz:
+	${WGET} http://ocsigen.org/download/$@
+obrowser: ${OBROWSER}.tar.gz lwt menhir
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OBROWSER}
+	tar zxf ${OBROWSER}.tar.gz
+	./Patcher.sh ${OBROWSER}
+	( cd ${OBROWSER} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} && \
+	  ocamlfind remove obrowser && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OBROWSER} obrowser
+distclean::
+	rm -f ${OBROWSER}.tar.gz
+all: obrowser
+
+# http://hevea.inria.fr/old/
+HEVEA=hevea-2.09
+${HEVEA}.tar.gz:
+	${WGET} http://hevea.inria.fr/old/$@
+hevea: ${HEVEA}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${HEVEA}
+	tar zxf ${HEVEA}.tar.gz
+	./Patcher.sh ${HEVEA}
+	( cd ${HEVEA} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} PREFIX=${PREFIX} && \
+	  ${MAKE} PREFIX=${PREFIX} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${HEVEA} hevea
+distclean::
+	rm -f ${HEVEA}.tar.gz
+all: hevea
+
+# http://www.seas.upenn.edu/~bcpierce/unison/download/releases/
+UNISON=unison-2.45.4
+${UNISON}.tar.gz:
+	${WGET} http://www.seas.upenn.edu/~bcpierce/unison/download/releases/unison-2.45.4/$@
+unison: ${UNISON}.tar.gz lablgtk
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${UNISON}
+	tar zxf ${UNISON}.tar.gz
+	./Patcher.sh ${UNISON}
+	( cd ${UNISON} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} UISTYLE=gtk2 && \
+	  touch ${PREFIX}/bin/unison && \
+	  ${MAKE} UISTYLE=gtk2 INSTALLDIR=${PREFIX}/bin/ install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${UNISON} unison
+distclean::
+	rm -f ${UNISON}.tar.gz
+all: unison
+
+# http://raevnos.pennmush.org/code/ocaml-mysql/
+MYSQL=ocaml-mysql-1.0.4
+${MYSQL}.tar.gz:
+	${WGET} http://raevnos.pennmush.org/code/ocaml-mysql/$@
+mysql: ${MYSQL}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${MYSQL}
+	tar zxf ${MYSQL}.tar.gz
+	./Patcher.sh ${MYSQL}
+	( cd ${MYSQL} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  export CPPFLAGS=-I/opt/local/include/mysql5 && \
+	  export LDFLAGS=-L/opt/local/lib/mysql5/mysql && \
+	  ./configure -prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} opt && \
+	  ocamlfind remove mysql && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${MYSQL} mysql
+distclean::
+	rm -f ${MYSQL}.tar.gz
+all: mysql
+
+# http://gallium.inria.fr/~guesdon/Tools/ocgi/
+OCGI=ocgi-0.5
+${OCGI}.tar.gz:
+	${WGET} http://pauillac.inria.fr/~guesdon/Tools/Tars/$@
+ocgi: ${OCGI}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCGI}
+	tar zxf ${OCGI}.tar.gz
+	./Patcher.sh ${OCGI}
+	( cd ${OCGI} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure && \
+	  ${MAKE} && \
+	  ${MAKE} opt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCGI} ocgi
+distclean::
+	rm -f ${OCGI}.tar.gz
+all: ocgi
+
+# http://tech.motion-twin.com/xmllight
+XMLLIGHT=xml-light-2.2
+${XMLLIGHT}.zip:
+	${WGET} http://tech.motion-twin.com/zip/$@
+xmllight: ${XMLLIGHT}.zip
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf xml-light ${XMLLIGHT}
+	unzip ${XMLLIGHT}.zip && mv xml-light ${XMLLIGHT}
+	./Patcher.sh ${XMLLIGHT}
+	( cd ${XMLLIGHT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} xml_parser.ml && \
+	  ${MAKE} all opt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${XMLLIGHT} xml-light xmllight
+distclean::
+	rm -f ${XMLLIGHT}.zip
+all: xmllight
+
+# http://config-file.forge.ocamlcore.org/
+CONFIGFILE=config-file-1.1
+${CONFIGFILE}.tar.gz:
+	${WGET} https://forge.ocamlcore.org/frs/download.php/845/$@
+configfile: ${CONFIGFILE}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CONFIGFILE}
+	tar zxf ${CONFIGFILE}.tar.gz
+	./Patcher.sh ${CONFIGFILE}
+	( cd ${CONFIGFILE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix=${PREFIX} && \
+	  ${MAKE} all && \
+	  ocamlfind remove config-file && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CONFIGFILE} configfile
+distclean::
+	rm -f ${CONFIGFILE}.tar.gz
+all: configfile
+
+# http://erratique.ch/software/xmlm
+XMLM=xmlm-1.1.0
+${XMLM}.tbz:
+	${WGET} http://erratique.ch/software/xmlm/releases/$@
+xmlm: ${XMLM}.tbz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${XMLM}
+	tar jxf ${XMLM}.tbz
+	./Patcher.sh ${XMLM} oasis-common.patch
+	( cd ${XMLM} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure --prefix ${PREFIX} && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove xmlm && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${XMLM} xmlm
+distclean::
+	rm -f ${XMLM}.tbz
+all: xmlm
+
+# http://forge.ocamlcore.org/projects/gtk-extras/
+LABLGTKEXTRAS=lablgtkextras-1.3
+${LABLGTKEXTRAS}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/1072/$@
+lablgtkextras: ${LABLGTKEXTRAS}.tar.gz lablgtk configfile xmlm
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${LABLGTKEXTRAS}
+	tar zxf ${LABLGTKEXTRAS}.tar.gz
+	./Patcher.sh ${LABLGTKEXTRAS}
+	( cd ${LABLGTKEXTRAS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} all && \
+	  ocamlfind remove lablgtk2-extras && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${LABLGTKEXTRAS} lablgtkextras
+distclean::
+	rm -f ${LABLGTKEXTRAS}.tar.gz
+all: lablgtkextras
+
+# https://bitbucket.org/skskeyserver/sks-keyserver/downloads
+SKS=sks-1.1.3
+${SKS}.tgz:
+	${WGET} https://bitbucket.org/skskeyserver/sks-keyserver/downloads/$@
+sks: ${SKS}.tgz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${SKS}
+	tar zxf ${SKS}.tgz
+	./Patcher.sh ${SKS}
+	( cd ${SKS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} dep PREFIX=${PREFIX} && \
+	  ${MAKE} all PREFIX=${PREFIX} && \
+	  ${MAKE} all.bc PREFIX=${PREFIX} && \
+	  ${MAKE} install PREFIX=${PREFIX} )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${SKS} sks
+distclean::
+	rm -f ${SKS}.tgz
+all: sks
+
+# http://omake.metaprl.org/download.html
+OMAKE=omake-0.9.8.6
+${OMAKE}-0.rc1.tar.gz:
+	${WGET} http://omake.metaprl.org/downloads/$@
+omake: ${OMAKE}-0.rc1.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OMAKE}
+	tar zxf ${OMAKE}-0.rc1.tar.gz
+	./Patcher.sh ${OMAKE}
+	( cd ${OMAKE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  export PREFIX=${PREFIX} && \
+	  ${MAKE} all && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OMAKE} omake
+distclean::
+	rm -f ${OMAKE}-0.rc1.tar.gz
+all: omake
+
+# http://alt-ergo.lri.fr/
+ALTERGO=alt-ergo-0.95
+${ALTERGO}.tar.gz:
+	${WGET} http://alt-ergo.lri.fr/http/$(ALTERGO)/$@
+altergo: ${ALTERGO}.tar.gz ocamlgraph
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${ALTERGO}
+	tar zxf ${ALTERGO}.tar.gz
+	./Patcher.sh ${ALTERGO}
+	( cd ${ALTERGO} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure -prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${ALTERGO} altergo
+distclean::
+	rm -f ${ALTERGO}.tar.gz
+all: altergo
+
+# http://www.seas.upenn.edu/~harmony/
+BOOMERANG=boomerang-0.2
+${BOOMERANG}-source.tar.gz:
+	${WGET} http://www.seas.upenn.edu/~harmony/download/$@
+boomerang: ${BOOMERANG}-source.tar.gz omake
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${BOOMERANG}
+	tar zxf ${BOOMERANG}-source.tar.gz && mv boomerang-20090902 ${BOOMERANG}
+	./Patcher.sh ${BOOMERANG}
+	( cd ${BOOMERANG} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  omake )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${BOOMERANG} boomerang
+distclean::
+	rm -f ${BOOMERANG}-source.tar.gz
+all: boomerang
+
+# https://github.com/yoriyuki/Camomile/wiki
+CAMOMILE=camomile-0.8.4
+${CAMOMILE}.tar.bz2:
+	${WGET} https://github.com/downloads/yoriyuki/Camomile/$@
+camomile: ${CAMOMILE}.tar.bz2
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CAMOMILE}
+	tar xf ${CAMOMILE}.tar.bz2
+	./Patcher.sh ${CAMOMILE}
+	( cd ${CAMOMILE} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure -prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove camomile && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CAMOMILE} camomile
+distclean::
+	rm -f ${CAMOMILE}.tar.bz2
+all: camomile
+
+# http://sanskrit.inria.fr/ZEN/
+ZEN=zen_2.3.2
+${ZEN}.tar.gz:
+	${WGET} http://sanskrit.inria.fr/ZEN/$@
+zen: ${ZEN}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${ZEN}
+	tar zxf ${ZEN}.tar.gz && mv ZEN_* ${ZEN}
+	./Patcher.sh ${ZEN}
+	( cd ${ZEN} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} depend && \
+	  ${MAKE} all && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${ZEN} zen
+distclean::
+	rm -f ${ZEN}.tar.gz
+all: zen
+
+# http://users-tima.imag.fr/vds/ouchet/index_fichiers/vsyml.html
+VSYML=vsyml-2010-04-06
+${VSYML}.tar.gz:
+	${WGET} http://users-tima.imag.fr/vds/ouchet/vsyml/$@
+vsyml: ${VSYML}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${VSYML}
+	tar zxf ${VSYML}.tar.gz
+	./Patcher.sh ${VSYML}
+	( cd ${VSYML} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${VSYML} vsyml
+distclean::
+	rm -f ${VSYML}.tar.gz
+all: vsyml
+
+# http://projects.camlcity.org/projects/ocamlnet.html
+OCAMLNET=ocamlnet-3.5.1
+${OCAMLNET}.tar.gz:
+	${WGET} http://download.camlcity.org/download/$@
+ocamlnet: ${OCAMLNET}.tar.gz findlib pcre lablgtk ocamlssl camlzip cryptokit
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLNET}
+	tar zxf ${OCAMLNET}.tar.gz
+	./Patcher.sh ${OCAMLNET}
+	( cd ${OCAMLNET} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure && \
+	  ${MAKE} all && \
+	  ${MAKE} opt && \
+	  ocamlfind remove netsys && \
+	  ocamlfind remove netshm && \
+	  ocamlfind remove netstring && \
+	  ocamlfind remove equeue && \
+	  ocamlfind remove shell && \
+	  ocamlfind remove rpc-generator && \
+	  ocamlfind remove rpc-auth-local && \
+	  ocamlfind remove rpc && \
+	  ocamlfind remove pop && \
+	  ocamlfind remove smtp && \
+	  ocamlfind remove netclient && \
+	  ocamlfind remove netcgi2 && \
+	  ocamlfind remove netplex && \
+	  ocamlfind remove netcgi2-plex && \
+	  ocamlfind remove netcamlbox && \
+	  ocamlfind remove netmulticore && \
+	  ocamlfind remove netgssapi && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLNET} ocamlnet
+distclean::
+	rm -f ${OCAMLNET}.tar.gz
+all: ocamlnet
+
+# http://zoggy.github.io/ocamlrss/
+RSS=ocamlrss-2.2.2
+${RSS}.tar.gz:
+	${WGET} http://zoggy.github.io/ocamlrss/$@
+rss: ${RSS}.tar.gz xmlm ocamlnet
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${RSS}
+	tar zxf ${RSS}.tar.gz
+	./Patcher.sh ${RSS}
+	( cd ${RSS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} all && \
+	  ocamlfind remove ocaml-rss && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${RSS} rss
+distclean::
+	rm -f ${RSS}.tar.gz
+all: rss
+
+# http://code.google.com/p/ocaml-extlib/
+EXTLIB=extlib-1.5.2
+${EXTLIB}.tar.gz:
+	${WGET} http://ocaml-extlib.googlecode.com/files/$@
+extlib: ${EXTLIB}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${EXTLIB}
+	tar zxf ${EXTLIB}.tar.gz
+	./Patcher.sh ${EXTLIB}
+	( cd ${EXTLIB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocamlfind remove extlib && \
+	  ocaml install.ml -b -n -doc )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${EXTLIB} extlib
+distclean::
+	rm -f ${EXTLIB}.tar.gz
+all: extlib
+
+# http://forge.ocamlcore.org/projects/ocaml-fileutils
+FILEUTILS=ocaml-fileutils-0.4.4
+${FILEUTILS}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/892/$@
+fileutils: ${FILEUTILS}.tar.gz findlib ounit
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${FILEUTILS}
+	tar xf ${FILEUTILS}.tar.gz
+	./Patcher.sh ${FILEUTILS}
+	( cd ${FILEUTILS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove fileutils && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${FILEUTILS} fileutils
+distclean::
+	rm -f ${FILEUTILS}.tar.gz
+all: fileutils
+
+# http://forge.ocamlcore.org/projects/odn
+ODN=ocaml-data-notation-0.0.10
+${ODN}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/1029/$@
+odn: ${ODN}.tar.gz findlib core ounit fileutils
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${ODN}
+	tar zxf ${ODN}.tar.gz
+	./Patcher.sh ${ODN} oasis-common.patch
+	( cd ${ODN} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove odn && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${ODN} odn
+distclean::
+	rm -f ${ODN}.tar.gz
+all: odn
+
+# http://forge.ocamlcore.org/projects/ocamlify
+OCAMLIFY=ocamlify-0.0.1
+${OCAMLIFY}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/379/$@
+ocamlify: ${OCAMLIFY}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLIFY}
+	tar zxf ${OCAMLIFY}.tar.gz
+	./Patcher.sh ${OCAMLIFY} oasis-common.patch
+	( cd ${OCAMLIFY} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ocaml setup.ml -build && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLIFY} ocamlify
+distclean::
+	rm -f ${OCAMLIFY}.tar.gz
+all: ocamlify
+
+# http://forge.ocamlcore.org/projects/ocaml-expect
+EXPECT=ocaml-expect-0.0.3
+${EXPECT}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/894/$@
+expect: ${EXPECT}.tar.gz findlib extlib pcre ounit
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${EXPECT}
+	tar zxf ${EXPECT}.tar.gz
+	./Patcher.sh ${EXPECT} oasis-common.patch
+	( cd ${EXPECT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ocaml setup.ml -configure && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove expect && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${EXPECT} expect
+distclean::
+	rm -f ${EXPECT}.tar.gz
+all: expect
+
+# http://forge.ocamlcore.org/projects/ocamlmod/
+OCAMLMOD=ocamlmod-0.0.3
+${OCAMLMOD}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/856/$@
+ocamlmod: ${OCAMLMOD}.tar.gz findlib fileutils pcre
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLMOD}
+	tar zxf ${OCAMLMOD}.tar.gz
+	./Patcher.sh ${OCAMLMOD}
+	( cd ${OCAMLMOD} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLMOD} ocamlmod
+distclean::
+	rm -f ${OCAMLMOD}.tar.gz
+all: ocamlmod
+
+# http://forge.ocamlcore.org/projects/oasis
+OASIS=oasis-0.3.0
+${OASIS}.tar.gz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/918/$@
+oasis: ${OASIS}.tar.gz findlib fileutils pcre extlib odn ocamlgraph ocamlify \
+       ounit expect ocamlmod
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OASIS}
+	tar zxf ${OASIS}.tar.gz
+	./Patcher.sh ${OASIS} oasis-common.patch
+	( cd ${OASIS} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ocaml setup.ml -build && \
+	  ocamlfind remove oasis && \
+	  ocamlfind remove userconf && \
+	  ocamlfind remove plugin-loader && \
+	  ocaml setup.ml -install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OASIS} oasis
+distclean::
+	rm -f ${OASIS}.tar.gz
+all: oasis
+
+# http://calendar.forge.ocamlcore.org/
+CALENDAR=calendar-2.03.2
+${CALENDAR}.tar.gz:
+	${WGET} https://forge.ocamlcore.org/frs/download.php/915/$@
+calendar: ${CALENDAR}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CALENDAR}
+	tar zxf ${CALENDAR}.tar.gz
+	./Patcher.sh ${CALENDAR}
+	( cd ${CALENDAR} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CALENDAR} calendar
+distclean::
+	rm -f ${CALENDAR}.tar.gz
+all: calendar
+
+# http://gallium.inria.fr/camlimages/
+CAMLIMAGES=camlimages-4.0.1
+${CAMLIMAGES}.tar.gz:
+	${WGET} https://bitbucket.org/camlspotter/camlimages/get/v4.0.1.tar.gz
+	mv v4.0.1.tar.gz $@
+camlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CAMLIMAGES}
+	tar xf ${CAMLIMAGES}.tar.gz
+	mv camlspotter-camlimages-c803efa9d5d3 ${CAMLIMAGES}
+	mv ${CAMLIMAGES}/doc/old/* ${CAMLIMAGES}/doc/
+	./Patcher.sh ${CAMLIMAGES}
+	( cd ${CAMLIMAGES} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  omake && \
+	  ocamlfind remove camlimages && \
+	  omake install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CAMLIMAGES} camlimages
+distclean::
+	rm -f ${CAMLIMAGES}.tar.gz
+all: camlimages
+
+# http://advi.inria.fr/
+ADVI=advi-1.10.2
+${ADVI}.tar.gz:
+	${WGET} http://advi.inria.fr/$@
+advi: ${ADVI}.tar.gz findlib camlimages
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${ADVI}
+	tar zxf ${ADVI}.tar.gz
+	./Patcher.sh ${ADVI}
+	( cd ${ADVI} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${ADVI} advi
+distclean::
+	rm -f ${ADVI}.tar.gz
+all: advi
+
+# http://forge.ocamlcore.org/projects/camldbm
+DBM=camldbm-1.0
+${DBM}.tgz:
+	${WGET} http://forge.ocamlcore.org/frs/download.php/728/$@
+dbm: ${DBM}.tgz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${DBM}
+	tar zxf ${DBM}.tgz
+	./Patcher.sh ${DBM}
+	( cd ${DBM} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${DBM} dbm
+distclean::
+	rm -f ${DBM}.tgz
+all: dbm
+
+# http://ocsigen.org/
+OCSIGEN=ocsigen-bundle-2.2.2
+${OCSIGEN}.tar.gz:
+	${WGET} http://ocsigen.org/download/$@
+ocsigen: ${OCSIGEN}.tar.gz findlib lwt obrowser pcre ocamlnet ocamlssl \
+         sqlite camlzip cryptokit calendar dbm
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCSIGEN}
+	tar zxf ${OCSIGEN}.tar.gz
+	./Patcher.sh ${OCSIGEN}
+	( cd ${OCSIGEN} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  export OCSIGEN_USER=${USER}; export OCSIGEN_GROUP=everyone && \
+	  ./configure --prefix=${PREFIX} && \
+	  ${MAKE} && \
+	  rm -rf ${PREFIX}/lib/ocaml/ocsigenserver/extensions && \
+	  ocamlfind remove -destdir ${PREFIX}/lib/ocaml deriving-ocsigen && \
+	  ocamlfind remove -destdir ${PREFIX}/lib/ocaml js_of_ocaml && \
+	  ocamlfind remove -destdir ${PREFIX}/lib/ocaml ocsigenserver && \
+	  ocamlfind remove -destdir ${PREFIX}/lib/ocaml tyxml && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCSIGEN} ocsigen
+distclean::
+	rm -f ${OCSIGEN}.tar.gz
+all: ocsigen
+
+# http://mldonkey.sourceforge.net/
+MLDONKEY=mldonkey-3.1.2
+${MLDONKEY}.tar.bz2:
+	${WGET} http://freefr.dl.sourceforge.net/project/mldonkey/mldonkey/3.1.2/$@
+mldonkey: ${MLDONKEY}.tar.bz2 lablgtk
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${MLDONKEY}
+	tar zxf ${MLDONKEY}.tar.bz2
+	./Patcher.sh ${MLDONKEY}
+	( cd ${MLDONKEY} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure && \
+	  ${MAKE} )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${MLDONKEY} mldonkey
+distclean::
+	rm -f ${MLDONKEY}.tar.bz2
+all: mldonkey
+
+# http://mjambon.com/releases/ocamlscript
+OCAMLSCRIPT=ocamlscript-2.0.3
+${OCAMLSCRIPT}.tar.gz:
+	${WGET} http://mjambon.com/releases/ocamlscript/$@
+ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${OCAMLSCRIPT}
+	tar xf ${OCAMLSCRIPT}.tar.gz
+	./Patcher.sh ${OCAMLSCRIPT}
+	( cd ${OCAMLSCRIPT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} && \
+	  ocamlfind remove ocamlscript && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${OCAMLSCRIPT} ocamlscript
+distclean::
+	rm -f ${OCAMLSCRIPT}.tar.bz2
+all: ocamlscript
+
+# https://forge.ocamlcore.org/projects/kaputt/
+KAPUTT=kaputt-1.2
+${KAPUTT}.tar.gz:
+	${WGET} https://forge.ocamlcore.org/frs/download.php/987/$@
+kaputt: ${KAPUTT}.tar.gz findlib
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${KAPUTT}
+	tar zxf ${KAPUTT}.tar.gz
+	./Patcher.sh ${KAPUTT}
+	( cd ${KAPUTT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure -ocaml-prefix ${PREFIX} && \
+	  ${MAKE} all && \
+	  ocamlfind remove kaputt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${KAPUTT} kaputt
+distclean::
+	rm -f ${KAPUTT}.tar.gz
+all: kaputt
+
+#http://www.coherentpdf.com/ocaml-libraries.html
+CAMLPDF=camlpdf-0.5
+${CAMLPDF}.tar.bz2:
+	${WGET} http://www.coherentpdf.com/$@
+camlpdf: ${CAMLPDF}.tar.bz2
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CAMLPDF}
+	tar zxf ${CAMLPDF}.tar.bz2
+	./Patcher.sh ${CAMLPDF}
+	( cd ${CAMLPDF} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ${MAKE} all && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CAMLPDF} camlpdf
+distclean::
+	rm -f ${CAMLPDF}.tar.gz
+all: camlpdf
+
+# http://pauillac.inria.fr/~ddr/camlp5/
+CAMLP5=camlp5-6.10
+${CAMLP5}.tgz:
+	${WGET} http://pauillac.inria.fr/~ddr/camlp5/distrib/src/$@
+camlp5: ${CAMLP5}.tgz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${CAMLP5}
+	tar zxf ${CAMLP5}.tgz
+	./Patcher.sh ${CAMLP5}
+	( cd ${CAMLP5} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure --transitional && \
+	  ${MAKE} world.opt && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${CAMLP5} camlp5
+distclean::
+	rm -f ${CAMLP5}.tgz
+all: camlp5
+
+# http://opensource.geneanet.org/projects/geneweb
+GENEWEB=gw-6.05-src
+${GENEWEB}.tgz:
+	${WGET} http://opensource.geneanet.org/attachments/download/190/$@
+geneweb: ${GENEWEB}.tgz camlp5
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${GENEWEB}
+	tar zxf ${GENEWEB}.tgz
+	./Patcher.sh ${GENEWEB}
+	( cd ${GENEWEB} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure && \
+	  ${MAKE} )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${GENEWEB} geneweb
+distclean::
+	rm -f ${GENEWEB}.tgz
+all: geneweb
+
+# http://coq.inria.fr/download
+COQ=coq-8.4pl1
+${COQ}.tar.gz:
+	${WGET} http://coq.inria.fr/distrib/V8.4pl1/files/$@
+coq: ${COQ}.tar.gz camlp5
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${COQ}
+	tar zxf ${COQ}.tar.gz
+	./Patcher.sh ${COQ}
+	( cd ${COQ} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure -prefix ${PREFIX} -with-doc no && \
+	  ${MAKE} world && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${COQ} coq
+distclean::
+	rm -f ${COQ}.tar.gz
+all: coq
+
+# http://code.google.com/p/bitstring/
+
+BITSTRING=ocaml-bitstring-2.0.3
+${BITSTRING}.tar.gz:
+	${WGET} http://bitstring.googlecode.com/files/$@
+bitstring: ${BITSTRING}.tar.gz findlib # cil FIXME ?
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${BITSTRING}
+	tar zxf ${BITSTRING}.tar.gz
+	./Patcher.sh ${BITSTRING}
+	( cd ${BITSTRING} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} check && \
+	  ${MAKE} examples && \
+	  ocamlfind remove bitstring && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${BITSTRING} bitstring
+distclean::
+	rm -f ${BITSTRING}.tar.gz
+all: bitstring
+
+# http://compcert.inria.fr
+COMPCERT=compcert-1.13
+${COMPCERT}.tgz:
+	${WGET} http://compcert.inria.fr/release/$@
+compcert: ${COMPCERT}.tgz coq bitstring
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${COMPCERT}
+	tar zxf ${COMPCERT}.tgz
+	./Patcher.sh ${COMPCERT}
+	( cd ${COMPCERT} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure -prefix ${PREFIX} ppc-linux && \
+	  ${MAKE} all && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${COMPCERT} compcert
+distclean::
+	rm -f ${COMPCERT}.tgz
+all: compcert
+
+# http://frama-c.com/
+FRAMAC=frama-c-Oxygen-20120901
+${FRAMAC}.tar.gz:
+	${WGET} http://frama-c.com/download/$@
+framac: ${FRAMAC}.tar.gz lablgtk ocamlgraph altergo coq
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${FRAMAC}
+	tar zxf ${FRAMAC}.tar.gz
+	./Patcher.sh ${FRAMAC}
+	( cd ${FRAMAC} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  ./configure --enable-verbosemake --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ${MAKE} oracles && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+clean::
+	rm -rf ${FRAMAC} framac
+distclean::
+	rm -f ${FRAMAC}.tar.gz
+all: framac
+
+##################################################################
+### Template for new entries
+##################################################################
+
+FOO=
+${FOO}.tar.gz:
+	${WGET} http://foo.bar.com/.../$@
+foo: ${FOO}.tar.gz
+	printf "%s " "$@" >/dev/tty
+	test -d ${PREFIX}
+	rm -rf ${FOO}
+	tar zxf ${FOO}.tar.gz
+	./Patcher.sh ${FOO}
+	( cd ${FOO} && \
+	  export PATH=${PREFIX}/bin:$$PATH && \
+	  sh ./configure --prefix ${PREFIX} && \
+	  ${MAKE} && \
+	  ocamlfind remove foo && \
+	  ${MAKE} install )
+	echo ${VERSION} >$@
+xxclean::
+	rm -rf ${FOO} foo
+xxdistclean::
+	rm -f ${FOO}.tar.gz
+xxall: foo
+
+##################################################################
+
+.PHONY: clean
+
+.PHONY: distclean
+distclean::
+	${MAKE} clean
+
+.PHONY: all
+all:
+	echo >/dev/tty
diff --git a/testsuite/external/Patcher.sh b/testsuite/external/Patcher.sh
new file mode 100755
index 00000000..57597d08
--- /dev/null
+++ b/testsuite/external/Patcher.sh
@@ -0,0 +1,31 @@
+#!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#           Damien Doligez, projet Gallium, INRIA Rocquencourt          #
+#                                                                       #
+#   Copyright 2012 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# usage:
+# Patcher.sh  []
+
+if [ -f "$1.patch" ]; then
+  echo "patch -d $1 -p1 < $1.patch"
+  patch -d $1 -p1 < "$1.patch"
+fi
+
+if [ -f "$1-$VERSION.patch" ]; then
+  echo "patch -d $1 -p1 < $1-$VERSION.patch"
+  patch -d $1 -p1 < "$1-$VERSION.patch"
+fi
+
+if [ -f "$2" ]; then
+  echo "patch -d $1 -l -p0 < $2"
+  patch -d $1 -l -p0 < "$2" || exit 0
+fi
diff --git a/testsuite/external/TODO.txt b/testsuite/external/TODO.txt
new file mode 100644
index 00000000..18a5460e
--- /dev/null
+++ b/testsuite/external/TODO.txt
@@ -0,0 +1,26 @@
+TODO:
+Understand why ocamlnet does not detect lablgtk, ocamlssl, camlzip, cryptokit
+
+TODO: cryptogps
+http://www.ocaml-programming.de/packages
+and make ocamlnet depend on it
+
+# TODO: lablgl
+# http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgl.html
+
+Haxe: missing a source archive of released version...
+# # http://code.google.com/p/haxe/source/browse/#svn%2Ftrunk
+# HAXE=haxe-2.10dev
+# haxe:
+# 	printf "%s " "$@" >/dev/tty
+# 	test -d ${PREFIX}
+# 	rm -rf ${HAXE}
+# 	tar zxf ${HAXE}.tar.gz
+# 	./Patcher.sh ${HAXE}
+# 	( cd ${HAXE} && \
+# 	  export PATH=${PREFIX}/bin:$$PATH && \
+# 	  make )
+# 	echo ${VERSION} >$@
+# clean::
+# 	rm -rf ${HAXE} haxe
+# all: haxe
diff --git a/testsuite/external/boomerang-0.2.patch b/testsuite/external/boomerang-0.2.patch
new file mode 100644
index 00000000..0bb8eb37
--- /dev/null
+++ b/testsuite/external/boomerang-0.2.patch
@@ -0,0 +1,11 @@
+--- boomerang-0.2/OMakefile.orig	2010-06-07 15:01:55.000000000 +0200
++++ boomerang-0.2/OMakefile	2010-06-07 15:02:08.000000000 +0200
+@@ -126,7 +126,7 @@
+ ##############################################################################
+ # Include sub-directories
+ 
+-SUBDIRS = common src lenses examples doc
++SUBDIRS = common src lenses examples #doc
+ 
+ .SUBDIRS: $(SUBDIRS)
+ 
diff --git a/testsuite/external/camlimages-4.0.1.patch b/testsuite/external/camlimages-4.0.1.patch
new file mode 100644
index 00000000..ff2f93e5
--- /dev/null
+++ b/testsuite/external/camlimages-4.0.1.patch
@@ -0,0 +1,11 @@
+--- camlimages-4.0.1.orig/OMakefile	2011-06-22 20:04:32.000000000 +0200
++++ camlimages-4.0.1/OMakefile	2013-02-19 15:35:38.000000000 +0100
+@@ -138,7 +138,7 @@
+     SUPPORTED_FORMATS+=jpeg
+     export
+ 
+-  HAVE_TIFF = $(Check_header_library tiff, tiff.h, TIFFOpen)
++  HAVE_TIFF = false # $(Check_header_library tiff, tiff.h, TIFFOpen)
+   SUPPORT_TIFF = $(and $(HAVE_Z) $(HAVE_JPEG) $(HAVE_TIFF))
+   LDFLAGS_tiff=
+   if $(SUPPORT_TIFF)
diff --git a/testsuite/external/camlp5-6.06.patch b/testsuite/external/camlp5-6.06.patch
new file mode 100644
index 00000000..8b7e58a3
--- /dev/null
+++ b/testsuite/external/camlp5-6.06.patch
@@ -0,0 +1,2243 @@
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++    Left of 'a
++  | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++  let loc_at n lnum bolp =
++    {Lexing.pos_fname = if lnum = -1 then "" else fname;
++     Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++  in
++  {Location.loc_start = loc_at bp lnum bolp;
++   Location.loc_end = loc_at ep lnuml bolpl;
++   Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++  let loc =
++    {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++     Lexing.pos_cnum = -1}
++  in
++  {Location.loc_start = loc; Location.loc_end = loc;
++   Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++  let mkli s =
++    let rec loop f =
++      function
++        i :: il -> loop (fun s -> Ldot (f i, s)) il
++      | [] -> f s
++    in
++    loop (fun s -> Lident s)
++  in
++  match List.rev sl with
++    [] -> None
++  | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++  let rec loop rev_l =
++    function
++      x :: l ->
++        begin match f x with
++          Some s -> loop (s :: rev_l) l
++        | None -> None
++        end
++    | [] -> Some (List.rev rev_l)
++  in
++  loop [] l
++;;
++
++let ocaml_value_description t p =
++  {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++  match list_map_check (fun s_opt -> s_opt) params with
++    Some params ->
++      let params = List.map (fun os -> Some (mknoloc os)) params in
++      Right
++        {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++         ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++         ptype_variance = variance}
++  | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++  Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++  let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++  Ptype_record
++    (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++  try
++    let ctl =
++      List.map
++        (fun (c, tl, rto, loc) ->
++           if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++        ctl
++    in
++    Some (Ptype_variant ctl)
++  with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++  let catl =
++    List.map
++      (function
++         Left (c, a, tl) -> Rtag (c, a, tl)
++       | Right t -> Rinherit t)
++      catl
++  in
++  Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++  mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++  Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++  Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++  Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++  let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++  let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++  Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++  let pexp_variant_pat =
++    function
++      Pexp_variant (lab, eo) -> Some (lab, eo)
++    | _ -> None
++  in
++  let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++  Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++  Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++  function
++    Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++  | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++  let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++  Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++  Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++  let ppat_variant_pat =
++    function
++      Ppat_variant (lab, po) -> Some (lab, po)
++    | _ -> None
++  in
++  let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++  Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++  let f ntl =
++    let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++    Psig_recmodule ntl
++  in
++  Some f
++;;
++
++let ocaml_psig_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++  Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++  let f nel =
++    Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++  in
++  Some f
++;;
++
++let ocaml_pstr_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++  Some
++    (fun virt (sl, sloc) name expr loc variance ->
++       let params = List.map (fun s -> mkloc loc s) sl, sloc in
++       {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++        pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++  let pf = if pf then Private else Public in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++  let mf = if mf then Mutable else Immutable in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++  let ocaml_pcf (s, mf, t, loc) =
++    let mf = if mf then Mutable else Immutable in
++    Pcf_valvirt (mkloc loc s, mf, t)
++  in
++  Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++  let f (t, ctfl) =
++    let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++    Pcty_signature cs
++  in
++  Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++  Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++  function
++    Arg.Rest r -> Some r
++  | _ -> None
++;;
++
++let arg_set_string =
++  function
++    Arg.Set_string r -> Some r
++  | _ -> None
++;;
++
++let arg_set_int =
++  function
++    Arg.Set_int r -> Some r
++  | _ -> None
++;;
++
++let arg_set_float =
++  function
++    Arg.Set_float r -> Some r
++  | _ -> None
++;;
++
++let arg_symbol =
++  function
++    Arg.Symbol (s, f) -> Some (s, f)
++  | _ -> None
++;;
++
++let arg_tuple =
++  function
++    Arg.Tuple t -> Some t
++  | _ -> None
++;;
++
++let arg_bool =
++  function
++    Arg.Bool f -> Some f
++  | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++	rm -f *.cmi
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++    Const_int of int
++  | Const_char of char
++  | Const_string of string
++  | Const_float of string
++  | Const_int32 of int32
++  | Const_int64 of int64
++  | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++  txt : 'a;
++  loc : Location.t;
++}
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++  loc_start: Lexing.position;
++  loc_end: Lexing.position;
++  loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++   If [pos_fname = ""], then use [!input_name] instead.
++   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++     re-parse the file to get the line and character numbers.
++   Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++    of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++  at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++  txt : 'a;
++  loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++    (** In -absname mode, return the absolute path for this filename.
++        Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++    Lident of string
++  | Ldot of t * string
++  | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++  { ptyp_desc: core_type_desc;
++    ptyp_loc: Location.t }
++
++and core_type_desc =
++    Ptyp_any
++  | Ptyp_var of string
++  | Ptyp_arrow of label * core_type * core_type
++  | Ptyp_tuple of core_type list
++  | Ptyp_constr of Longident.t loc * core_type list
++  | Ptyp_object of core_field_type list
++  | Ptyp_class of Longident.t loc * core_type list * label list
++  | Ptyp_alias of core_type * string
++  | Ptyp_variant of row_field list * bool * label list option
++  | Ptyp_poly of string list * core_type
++  | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++  { pfield_desc: core_field_desc;
++    pfield_loc: Location.t }
++
++and core_field_desc =
++    Pfield of string * core_type
++  | Pfield_var
++
++and row_field =
++    Rtag of label * bool * core_type list
++  | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++  { pci_virt: virtual_flag;
++    pci_params: string loc list * Location.t;
++    pci_name: string loc;
++    pci_expr: 'a;
++    pci_variance: (bool * bool) list;
++    pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++  { ppat_desc: pattern_desc;
++    ppat_loc: Location.t }
++
++and pattern_desc =
++    Ppat_any
++  | Ppat_var of string loc
++  | Ppat_alias of pattern * string loc
++  | Ppat_constant of constant
++  | Ppat_tuple of pattern list
++  | Ppat_construct of Longident.t loc * pattern option * bool
++  | Ppat_variant of label * pattern option
++  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++  | Ppat_array of pattern list
++  | Ppat_or of pattern * pattern
++  | Ppat_constraint of pattern * core_type
++  | Ppat_type of Longident.t loc
++  | Ppat_lazy of pattern
++  | Ppat_unpack of string loc
++
++type expression =
++  { pexp_desc: expression_desc;
++    pexp_loc: Location.t }
++
++and expression_desc =
++    Pexp_ident of Longident.t loc
++  | Pexp_constant of constant
++  | Pexp_let of rec_flag * (pattern * expression) list * expression
++  | Pexp_function of label * expression option * (pattern * expression) list
++  | Pexp_apply of expression * (label * expression) list
++  | Pexp_match of expression * (pattern * expression) list
++  | Pexp_try of expression * (pattern * expression) list
++  | Pexp_tuple of expression list
++  | Pexp_construct of Longident.t loc * expression option * bool
++  | Pexp_variant of label * expression option
++  | Pexp_record of (Longident.t loc * expression) list * expression option
++  | Pexp_field of expression * Longident.t loc
++  | Pexp_setfield of expression * Longident.t loc * expression
++  | Pexp_array of expression list
++  | Pexp_ifthenelse of expression * expression * expression option
++  | Pexp_sequence of expression * expression
++  | Pexp_while of expression * expression
++  | Pexp_for of string loc *  expression * expression * direction_flag * expression
++  | Pexp_constraint of expression * core_type option * core_type option
++  | Pexp_when of expression * expression
++  | Pexp_send of expression * string
++  | Pexp_new of Longident.t loc
++  | Pexp_setinstvar of string loc * expression
++  | Pexp_override of (string loc * expression) list
++  | Pexp_letmodule of string loc * module_expr * expression
++  | Pexp_assert of expression
++  | Pexp_assertfalse
++  | Pexp_lazy of expression
++  | Pexp_poly of expression * core_type option
++  | Pexp_object of class_structure
++  | Pexp_newtype of string * expression
++  | Pexp_pack of module_expr
++  | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++  { pval_type: core_type;
++    pval_prim: string list;
++    pval_loc : Location.t
++    }
++
++(* Type declarations *)
++
++and type_declaration =
++  { ptype_params: string loc option list;
++    ptype_cstrs: (core_type * core_type * Location.t) list;
++    ptype_kind: type_kind;
++    ptype_private: private_flag;
++    ptype_manifest: core_type option;
++    ptype_variance: (bool * bool) list;
++    ptype_loc: Location.t }
++
++and type_kind =
++    Ptype_abstract
++  | Ptype_variant of
++      (string loc * core_type list * core_type option * Location.t) list
++  | Ptype_record of
++      (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++  { pcty_desc: class_type_desc;
++    pcty_loc: Location.t }
++
++and class_type_desc =
++    Pcty_constr of Longident.t loc * core_type list
++  | Pcty_signature of class_signature
++  | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++    pcsig_self : core_type;
++    pcsig_fields : class_type_field list;
++    pcsig_loc : Location.t;
++  }
++
++and class_type_field = {
++    pctf_desc : class_type_field_desc;
++    pctf_loc : Location.t;
++  }
++
++and class_type_field_desc =
++    Pctf_inher of class_type
++  | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++  | Pctf_virt  of (string * private_flag * core_type)
++  | Pctf_meth  of (string * private_flag * core_type)
++  | Pctf_cstr  of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++  { pcl_desc: class_expr_desc;
++    pcl_loc: Location.t }
++
++and class_expr_desc =
++    Pcl_constr of Longident.t loc * core_type list
++  | Pcl_structure of class_structure
++  | Pcl_fun of label * expression option * pattern * class_expr
++  | Pcl_apply of class_expr * (label * expression) list
++  | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++  | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++    pcstr_pat : pattern;
++    pcstr_fields :  class_field list;
++  }
++
++and class_field = {
++    pcf_desc : class_field_desc;
++    pcf_loc : Location.t;
++  }
++
++and class_field_desc =
++    Pcf_inher of override_flag * class_expr * string option
++  | Pcf_valvirt of (string loc * mutable_flag * core_type)
++  | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++  | Pcf_virt  of (string loc * private_flag * core_type)
++  | Pcf_meth of (string loc * private_flag *override_flag * expression)
++  | Pcf_constr  of (core_type * core_type)
++  | Pcf_init  of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++  { pmty_desc: module_type_desc;
++    pmty_loc: Location.t }
++
++and module_type_desc =
++    Pmty_ident of Longident.t loc
++  | Pmty_signature of signature
++  | Pmty_functor of string loc * module_type * module_type
++  | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++  | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++  { psig_desc: signature_item_desc;
++    psig_loc: Location.t }
++
++and signature_item_desc =
++    Psig_value of string loc * value_description
++  | Psig_type of (string loc * type_declaration) list
++  | Psig_exception of string loc * exception_declaration
++  | Psig_module of string loc * module_type
++  | Psig_recmodule of (string loc * module_type) list
++  | Psig_modtype of string loc * modtype_declaration
++  | Psig_open of Longident.t loc
++  | Psig_include of module_type
++  | Psig_class of class_description list
++  | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++    Pmodtype_abstract
++  | Pmodtype_manifest of module_type
++
++and with_constraint =
++    Pwith_type of type_declaration
++  | Pwith_module of Longident.t loc
++  | Pwith_typesubst of type_declaration
++  | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++  { pmod_desc: module_expr_desc;
++    pmod_loc: Location.t }
++
++and module_expr_desc =
++    Pmod_ident of Longident.t loc
++  | Pmod_structure of structure
++  | Pmod_functor of string loc * module_type * module_expr
++  | Pmod_apply of module_expr * module_expr
++  | Pmod_constraint of module_expr * module_type
++  | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++  { pstr_desc: structure_item_desc;
++    pstr_loc: Location.t }
++
++and structure_item_desc =
++    Pstr_eval of expression
++  | Pstr_value of rec_flag * (pattern * expression) list
++  | Pstr_primitive of string loc * value_description
++  | Pstr_type of (string loc * type_declaration) list
++  | Pstr_exception of string loc * exception_declaration
++  | Pstr_exn_rebind of string loc * Longident.t loc
++  | Pstr_module of string loc * module_expr
++  | Pstr_recmodule of (string loc * module_type * module_expr) list
++  | Pstr_modtype of string loc * module_type
++  | Pstr_open of Longident.t loc
++  | Pstr_class of class_declaration list
++  | Pstr_class_type of class_type_declaration list
++  | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++    Ptop_def of structure
++  | Ptop_dir of string * directive_argument
++
++and directive_argument =
++    Pdir_none
++  | Pdir_string of string
++  | Pdir_int of int
++  | Pdir_ident of Longident.t
++  | Pdir_bool of bool
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++pconfig.cmo : pconfig.cmi
++pconfig.cmx : pconfig.cmi
++pconfig.cmi :
++warnings.cmi :
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++	rm -f *.cm[oix] *.o
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++	$(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml	2012-07-31 16:53:40.000000000 +0200
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.1"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
++(*                                                                     *)
++(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++  | Comment_start                           (*  1 *)
++  | Comment_not_end                         (*  2 *)
++  | Deprecated                              (*  3 *)
++  | Fragile_match of string                 (*  4 *)
++  | Partial_application                     (*  5 *)
++  | Labels_omitted                          (*  6 *)
++  | Method_override of string list          (*  7 *)
++  | Partial_match of string                 (*  8 *)
++  | Non_closed_record_pattern of string     (*  9 *)
++  | Statement_type                          (* 10 *)
++  | Unused_match                            (* 11 *)
++  | Unused_pat                              (* 12 *)
++  | Instance_variable_override of string list (* 13 *)
++  | Illegal_backslash                       (* 14 *)
++  | Implicit_public_methods of string list  (* 15 *)
++  | Unerasable_optional_argument            (* 16 *)
++  | Undeclared_virtual_method of string     (* 17 *)
++  | Not_principal of string                 (* 18 *)
++  | Without_principality of string          (* 19 *)
++  | Unused_argument                         (* 20 *)
++  | Nonreturning_statement                  (* 21 *)
++  | Camlp4 of string                        (* 22 *)
++  | Useless_record_with                     (* 23 *)
++  | Bad_module_name of string               (* 24 *)
++  | All_clauses_guarded                     (* 25 *)
++  | Unused_var of string                    (* 26 *)
++  | Unused_var_strict of string             (* 27 *)
++  | Wildcard_arg_to_constant_constr         (* 28 *)
++  | Eol_in_string                           (* 29 *)
++  | Duplicate_definitions of string * string * string * string (*30 *)
++  | Multiple_definition of string * string * string (* 31 *)
++  | Unused_value_declaration of string      (* 32 *)
++  | Unused_open of string                   (* 33 *)
++  | Unused_type_declaration of string       (* 34 *)
++  | Unused_for_index of string              (* 35 *)
++  | Unused_ancestor of string               (* 36 *)
++  | Unused_constructor of string * bool * bool  (* 37 *)
++  | Unused_exception of string * bool       (* 38 *)
++  | Unused_rec_flag                         (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++  (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+--- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig	2013-02-18 15:14:16.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli	2013-02-18 15:14:31.000000000 +0100
+@@ -54,6 +54,10 @@
+   | Unused_constructor of string * bool * bool  (* 37 *)
+   | Unused_exception of string * bool       (* 38 *)
+   | Unused_rec_flag                         (* 39 *)
++  | Name_out_of_scope of string list * bool (* 40 *)
++  | Ambiguous_name of string list * bool    (* 41 *)
++  | Disambiguated_name of string            (* 42 *)
++  | Nonoptional_label of string             (* 43 *)
+ ;;
+ 
+ val parse_options : bool -> string -> unit;;
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++	rm -f *.cmi
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++    Const_int of int
++  | Const_char of char
++  | Const_string of string
++  | Const_float of string
++  | Const_int32 of int32
++  | Const_int64 of int64
++  | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++  txt : 'a;
++  loc : Location.t;
++}
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++  loc_start: Lexing.position;
++  loc_end: Lexing.position;
++  loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++   If [pos_fname = ""], then use [!input_name] instead.
++   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++     re-parse the file to get the line and character numbers.
++   Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++    of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++  at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++  txt : 'a;
++  loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++    (** In -absname mode, return the absolute path for this filename.
++        Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++    Lident of string
++  | Ldot of t * string
++  | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++  { ptyp_desc: core_type_desc;
++    ptyp_loc: Location.t }
++
++and core_type_desc =
++    Ptyp_any
++  | Ptyp_var of string
++  | Ptyp_arrow of label * core_type * core_type
++  | Ptyp_tuple of core_type list
++  | Ptyp_constr of Longident.t loc * core_type list
++  | Ptyp_object of core_field_type list
++  | Ptyp_class of Longident.t loc * core_type list * label list
++  | Ptyp_alias of core_type * string
++  | Ptyp_variant of row_field list * bool * label list option
++  | Ptyp_poly of string list * core_type
++  | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++  { pfield_desc: core_field_desc;
++    pfield_loc: Location.t }
++
++and core_field_desc =
++    Pfield of string * core_type
++  | Pfield_var
++
++and row_field =
++    Rtag of label * bool * core_type list
++  | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++  { pci_virt: virtual_flag;
++    pci_params: string loc list * Location.t;
++    pci_name: string loc;
++    pci_expr: 'a;
++    pci_variance: (bool * bool) list;
++    pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++  { ppat_desc: pattern_desc;
++    ppat_loc: Location.t }
++
++and pattern_desc =
++    Ppat_any
++  | Ppat_var of string loc
++  | Ppat_alias of pattern * string loc
++  | Ppat_constant of constant
++  | Ppat_tuple of pattern list
++  | Ppat_construct of Longident.t loc * pattern option * bool
++  | Ppat_variant of label * pattern option
++  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++  | Ppat_array of pattern list
++  | Ppat_or of pattern * pattern
++  | Ppat_constraint of pattern * core_type
++  | Ppat_type of Longident.t loc
++  | Ppat_lazy of pattern
++  | Ppat_unpack of string loc
++
++type expression =
++  { pexp_desc: expression_desc;
++    pexp_loc: Location.t }
++
++and expression_desc =
++    Pexp_ident of Longident.t loc
++  | Pexp_constant of constant
++  | Pexp_let of rec_flag * (pattern * expression) list * expression
++  | Pexp_function of label * expression option * (pattern * expression) list
++  | Pexp_apply of expression * (label * expression) list
++  | Pexp_match of expression * (pattern * expression) list
++  | Pexp_try of expression * (pattern * expression) list
++  | Pexp_tuple of expression list
++  | Pexp_construct of Longident.t loc * expression option * bool
++  | Pexp_variant of label * expression option
++  | Pexp_record of (Longident.t loc * expression) list * expression option
++  | Pexp_field of expression * Longident.t loc
++  | Pexp_setfield of expression * Longident.t loc * expression
++  | Pexp_array of expression list
++  | Pexp_ifthenelse of expression * expression * expression option
++  | Pexp_sequence of expression * expression
++  | Pexp_while of expression * expression
++  | Pexp_for of string loc *  expression * expression * direction_flag * expression
++  | Pexp_constraint of expression * core_type option * core_type option
++  | Pexp_when of expression * expression
++  | Pexp_send of expression * string
++  | Pexp_new of Longident.t loc
++  | Pexp_setinstvar of string loc * expression
++  | Pexp_override of (string loc * expression) list
++  | Pexp_letmodule of string loc * module_expr * expression
++  | Pexp_assert of expression
++  | Pexp_assertfalse
++  | Pexp_lazy of expression
++  | Pexp_poly of expression * core_type option
++  | Pexp_object of class_structure
++  | Pexp_newtype of string * expression
++  | Pexp_pack of module_expr
++  | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++  { pval_type: core_type;
++    pval_prim: string list;
++    pval_loc : Location.t
++    }
++
++(* Type declarations *)
++
++and type_declaration =
++  { ptype_params: string loc option list;
++    ptype_cstrs: (core_type * core_type * Location.t) list;
++    ptype_kind: type_kind;
++    ptype_private: private_flag;
++    ptype_manifest: core_type option;
++    ptype_variance: (bool * bool) list;
++    ptype_loc: Location.t }
++
++and type_kind =
++    Ptype_abstract
++  | Ptype_variant of
++      (string loc * core_type list * core_type option * Location.t) list
++  | Ptype_record of
++      (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++  { pcty_desc: class_type_desc;
++    pcty_loc: Location.t }
++
++and class_type_desc =
++    Pcty_constr of Longident.t loc * core_type list
++  | Pcty_signature of class_signature
++  | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++    pcsig_self : core_type;
++    pcsig_fields : class_type_field list;
++    pcsig_loc : Location.t;
++  }
++
++and class_type_field = {
++    pctf_desc : class_type_field_desc;
++    pctf_loc : Location.t;
++  }
++
++and class_type_field_desc =
++    Pctf_inher of class_type
++  | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++  | Pctf_virt  of (string * private_flag * core_type)
++  | Pctf_meth  of (string * private_flag * core_type)
++  | Pctf_cstr  of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++  { pcl_desc: class_expr_desc;
++    pcl_loc: Location.t }
++
++and class_expr_desc =
++    Pcl_constr of Longident.t loc * core_type list
++  | Pcl_structure of class_structure
++  | Pcl_fun of label * expression option * pattern * class_expr
++  | Pcl_apply of class_expr * (label * expression) list
++  | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++  | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++    pcstr_pat : pattern;
++    pcstr_fields :  class_field list;
++  }
++
++and class_field = {
++    pcf_desc : class_field_desc;
++    pcf_loc : Location.t;
++  }
++
++and class_field_desc =
++    Pcf_inher of override_flag * class_expr * string option
++  | Pcf_valvirt of (string loc * mutable_flag * core_type)
++  | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++  | Pcf_virt  of (string loc * private_flag * core_type)
++  | Pcf_meth of (string loc * private_flag *override_flag * expression)
++  | Pcf_constr  of (core_type * core_type)
++  | Pcf_init  of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++  { pmty_desc: module_type_desc;
++    pmty_loc: Location.t }
++
++and module_type_desc =
++    Pmty_ident of Longident.t loc
++  | Pmty_signature of signature
++  | Pmty_functor of string loc * module_type * module_type
++  | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++  | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++  { psig_desc: signature_item_desc;
++    psig_loc: Location.t }
++
++and signature_item_desc =
++    Psig_value of string loc * value_description
++  | Psig_type of (string loc * type_declaration) list
++  | Psig_exception of string loc * exception_declaration
++  | Psig_module of string loc * module_type
++  | Psig_recmodule of (string loc * module_type) list
++  | Psig_modtype of string loc * modtype_declaration
++  | Psig_open of Longident.t loc
++  | Psig_include of module_type
++  | Psig_class of class_description list
++  | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++    Pmodtype_abstract
++  | Pmodtype_manifest of module_type
++
++and with_constraint =
++    Pwith_type of type_declaration
++  | Pwith_module of Longident.t loc
++  | Pwith_typesubst of type_declaration
++  | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++  { pmod_desc: module_expr_desc;
++    pmod_loc: Location.t }
++
++and module_expr_desc =
++    Pmod_ident of Longident.t loc
++  | Pmod_structure of structure
++  | Pmod_functor of string loc * module_type * module_expr
++  | Pmod_apply of module_expr * module_expr
++  | Pmod_constraint of module_expr * module_type
++  | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++  { pstr_desc: structure_item_desc;
++    pstr_loc: Location.t }
++
++and structure_item_desc =
++    Pstr_eval of expression
++  | Pstr_value of rec_flag * (pattern * expression) list
++  | Pstr_primitive of string loc * value_description
++  | Pstr_type of (string loc * type_declaration) list
++  | Pstr_exception of string loc * exception_declaration
++  | Pstr_exn_rebind of string loc * Longident.t loc
++  | Pstr_module of string loc * module_expr
++  | Pstr_recmodule of (string loc * module_type * module_expr) list
++  | Pstr_modtype of string loc * module_type
++  | Pstr_open of Longident.t loc
++  | Pstr_class of class_declaration list
++  | Pstr_class_type of class_type_declaration list
++  | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++    Ptop_def of structure
++  | Ptop_dir of string * directive_argument
++
++and directive_argument =
++    Pdir_none
++  | Pdir_string of string
++  | Pdir_int of int
++  | Pdir_ident of Longident.t
++  | Pdir_bool of bool
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,2 @@
++pconfig.cmo: pconfig.cmi
++pconfig.cmx: pconfig.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++	rm -f *.cm[oix] *.o
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++	$(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.2"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
++(*                                                                     *)
++(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++  | Comment_start                           (*  1 *)
++  | Comment_not_end                         (*  2 *)
++  | Deprecated                              (*  3 *)
++  | Fragile_match of string                 (*  4 *)
++  | Partial_application                     (*  5 *)
++  | Labels_omitted                          (*  6 *)
++  | Method_override of string list          (*  7 *)
++  | Partial_match of string                 (*  8 *)
++  | Non_closed_record_pattern of string     (*  9 *)
++  | Statement_type                          (* 10 *)
++  | Unused_match                            (* 11 *)
++  | Unused_pat                              (* 12 *)
++  | Instance_variable_override of string list (* 13 *)
++  | Illegal_backslash                       (* 14 *)
++  | Implicit_public_methods of string list  (* 15 *)
++  | Unerasable_optional_argument            (* 16 *)
++  | Undeclared_virtual_method of string     (* 17 *)
++  | Not_principal of string                 (* 18 *)
++  | Without_principality of string          (* 19 *)
++  | Unused_argument                         (* 20 *)
++  | Nonreturning_statement                  (* 21 *)
++  | Camlp4 of string                        (* 22 *)
++  | Useless_record_with                     (* 23 *)
++  | Bad_module_name of string               (* 24 *)
++  | All_clauses_guarded                     (* 25 *)
++  | Unused_var of string                    (* 26 *)
++  | Unused_var_strict of string             (* 27 *)
++  | Wildcard_arg_to_constant_constr         (* 28 *)
++  | Eol_in_string                           (* 29 *)
++  | Duplicate_definitions of string * string * string * string (*30 *)
++  | Multiple_definition of string * string * string (* 31 *)
++  | Unused_value_declaration of string      (* 32 *)
++  | Unused_open of string                   (* 33 *)
++  | Unused_type_declaration of string       (* 34 *)
++  | Unused_for_index of string              (* 35 *)
++  | Unused_ancestor of string               (* 36 *)
++  | Unused_constructor of string * bool * bool  (* 37 *)
++  | Unused_exception of string * bool       (* 38 *)
++  | Unused_rec_flag                         (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++  (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++    Left of 'a
++  | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++  let loc_at n lnum bolp =
++    {Lexing.pos_fname = if lnum = -1 then "" else fname;
++     Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++  in
++  {Location.loc_start = loc_at bp lnum bolp;
++   Location.loc_end = loc_at ep lnuml bolpl;
++   Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++  let loc =
++    {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++     Lexing.pos_cnum = -1}
++  in
++  {Location.loc_start = loc; Location.loc_end = loc;
++   Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++  let mkli s =
++    let rec loop f =
++      function
++        i :: il -> loop (fun s -> Ldot (f i, s)) il
++      | [] -> f s
++    in
++    loop (fun s -> Lident s)
++  in
++  match List.rev sl with
++    [] -> None
++  | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++  let rec loop rev_l =
++    function
++      x :: l ->
++        begin match f x with
++          Some s -> loop (s :: rev_l) l
++        | None -> None
++        end
++    | [] -> Some (List.rev rev_l)
++  in
++  loop [] l
++;;
++
++let ocaml_value_description t p =
++  {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++  match list_map_check (fun s_opt -> s_opt) params with
++    Some params ->
++      let params = List.map (fun os -> Some (mknoloc os)) params in
++      Right
++        {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++         ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++         ptype_variance = variance}
++  | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++  Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++  let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++  Ptype_record
++    (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++  try
++    let ctl =
++      List.map
++        (fun (c, tl, rto, loc) ->
++           if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++        ctl
++    in
++    Some (Ptype_variant ctl)
++  with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++  let catl =
++    List.map
++      (function
++         Left (c, a, tl) -> Rtag (c, a, tl)
++       | Right t -> Rinherit t)
++      catl
++  in
++  Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++  mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++  Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++  Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++  Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++  let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++  let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++  Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++  let pexp_variant_pat =
++    function
++      Pexp_variant (lab, eo) -> Some (lab, eo)
++    | _ -> None
++  in
++  let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++  Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++  Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++  function
++    Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++  | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++  let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++  Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++  Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++  let ppat_variant_pat =
++    function
++      Ppat_variant (lab, po) -> Some (lab, po)
++    | _ -> None
++  in
++  let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++  Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++  let f ntl =
++    let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++    Psig_recmodule ntl
++  in
++  Some f
++;;
++
++let ocaml_psig_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++  Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++  let f nel =
++    Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++  in
++  Some f
++;;
++
++let ocaml_pstr_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++  Some
++    (fun virt (sl, sloc) name expr loc variance ->
++       let params = List.map (fun s -> mkloc loc s) sl, sloc in
++       {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++        pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++  let pf = if pf then Private else Public in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++  let mf = if mf then Mutable else Immutable in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++  let ocaml_pcf (s, mf, t, loc) =
++    let mf = if mf then Mutable else Immutable in
++    Pcf_valvirt (mkloc loc s, mf, t)
++  in
++  Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++  let f (t, ctfl) =
++    let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++    Pcty_signature cs
++  in
++  Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++  Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++  function
++    Arg.Rest r -> Some r
++  | _ -> None
++;;
++
++let arg_set_string =
++  function
++    Arg.Set_string r -> Some r
++  | _ -> None
++;;
++
++let arg_set_int =
++  function
++    Arg.Set_int r -> Some r
++  | _ -> None
++;;
++
++let arg_set_float =
++  function
++    Arg.Set_float r -> Some r
++  | _ -> None
++;;
++
++let arg_symbol =
++  function
++    Arg.Symbol (s, f) -> Some (s, f)
++  | _ -> None
++;;
++
++let arg_tuple =
++  function
++    Arg.Tuple t -> Some t
++  | _ -> None
++;;
++
++let arg_bool =
++  function
++    Arg.Bool f -> Some f
++  | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
diff --git a/testsuite/external/camlp5-6.08.patch b/testsuite/external/camlp5-6.08.patch
new file mode 100644
index 00000000..60d708d6
--- /dev/null
+++ b/testsuite/external/camlp5-6.08.patch
@@ -0,0 +1,1127 @@
+--- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig	2013-02-18 15:14:16.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli	2013-02-18 15:14:31.000000000 +0100
+@@ -54,6 +54,10 @@
+   | Unused_constructor of string * bool * bool  (* 37 *)
+   | Unused_exception of string * bool       (* 38 *)
+   | Unused_rec_flag                         (* 39 *)
++  | Name_out_of_scope of string list * bool (* 40 *)
++  | Ambiguous_name of string list * string list * bool    (* 41 *)
++  | Disambiguated_name of string            (* 42 *)
++  | Nonoptional_label of string             (* 43 *)
+ ;;
+ 
+ val parse_options : bool -> string -> unit;;
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oi]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++asttypes.cmi : location.cmi
++location.cmi : ../utils/warnings.cmi
++longident.cmi :
++parsetree.cmi : longident.cmi location.cmi asttypes.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,19 @@
++# Id
++
++FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi
++INCL=-I ../utils
++
++all: $(FILES)
++
++clean:
++	rm -f *.cmi
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,45 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
++
++type constant =
++    Const_int of int
++  | Const_char of char
++  | Const_string of string
++  | Const_float of string
++  | Const_int32 of int32
++  | Const_int64 of int64
++  | Const_nativeint of nativeint
++
++type rec_flag = Nonrecursive | Recursive | Default
++
++type direction_flag = Upto | Downto
++
++type private_flag = Private | Public
++
++type mutable_flag = Immutable | Mutable
++
++type virtual_flag = Virtual | Concrete
++
++type override_flag = Override | Fresh
++
++type closed_flag = Closed | Open
++
++type label = string
++
++type 'a loc = 'a Location.loc = {
++  txt : 'a;
++  loc : Location.t;
++}
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,80 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Source code locations (ranges of positions), used in parsetree. *)
++
++open Format
++
++type t = {
++  loc_start: Lexing.position;
++  loc_end: Lexing.position;
++  loc_ghost: bool;
++}
++
++(* Note on the use of Lexing.position in this module.
++   If [pos_fname = ""], then use [!input_name] instead.
++   If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
++     re-parse the file to get the line and character numbers.
++   Else all fields are correct.
++*)
++
++val none : t
++(** An arbitrary value of type [t]; describes an empty ghost range. *)
++val in_file : string -> t;;
++(** Return an empty ghost range located in a given file. *)
++val init : Lexing.lexbuf -> string -> unit
++(** Set the file name and line number of the [lexbuf] to be the start
++    of the named file. *)
++val curr : Lexing.lexbuf -> t
++(** Get the location of the current token from the [lexbuf]. *)
++
++val symbol_rloc: unit -> t
++val symbol_gloc: unit -> t
++
++(** [rhs_loc n] returns the location of the symbol at position [n], starting
++  at 1, in the current parser rule. *)
++val rhs_loc: int -> t
++
++val input_name: string ref
++val input_lexbuf: Lexing.lexbuf option ref
++
++val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
++val print_loc: formatter -> t -> unit
++val print_error: formatter -> t -> unit
++val print_error_cur_file: formatter -> unit
++val print_warning: t -> formatter -> Warnings.t -> unit
++val prerr_warning: t -> Warnings.t -> unit
++val echo_eof: unit -> unit
++val reset: unit -> unit
++
++val highlight_locations: formatter -> t -> t -> bool
++
++type 'a loc = {
++  txt : 'a;
++  loc : t;
++}
++
++val mknoloc : 'a -> 'a loc
++val mkloc : 'a -> t -> 'a loc
++
++val print: formatter -> t -> unit
++val print_filename: formatter -> string -> unit
++
++val show_filename: string -> string
++    (** In -absname mode, return the absolute path for this filename.
++        Otherwise, returns the filename unchanged. *)
++
++
++val absname: bool ref
++
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,24 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Long identifiers, used in parsetree. *)
++
++type t =
++    Lident of string
++  | Ldot of t * string
++  | Lapply of t * t
++
++val flatten: t -> string list
++val last: t -> string
++val parse: string -> t
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,307 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
++(*                                                                     *)
++(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++(* Abstract syntax tree produced by parsing *)
++
++open Asttypes
++
++(* Type expressions for the core language *)
++
++type core_type =
++  { ptyp_desc: core_type_desc;
++    ptyp_loc: Location.t }
++
++and core_type_desc =
++    Ptyp_any
++  | Ptyp_var of string
++  | Ptyp_arrow of label * core_type * core_type
++  | Ptyp_tuple of core_type list
++  | Ptyp_constr of Longident.t loc * core_type list
++  | Ptyp_object of core_field_type list
++  | Ptyp_class of Longident.t loc * core_type list * label list
++  | Ptyp_alias of core_type * string
++  | Ptyp_variant of row_field list * bool * label list option
++  | Ptyp_poly of string list * core_type
++  | Ptyp_package of package_type
++
++
++and package_type = Longident.t loc * (Longident.t loc * core_type) list
++
++and core_field_type =
++  { pfield_desc: core_field_desc;
++    pfield_loc: Location.t }
++
++and core_field_desc =
++    Pfield of string * core_type
++  | Pfield_var
++
++and row_field =
++    Rtag of label * bool * core_type list
++  | Rinherit of core_type
++
++(* Type expressions for the class language *)
++
++type 'a class_infos =
++  { pci_virt: virtual_flag;
++    pci_params: string loc list * Location.t;
++    pci_name: string loc;
++    pci_expr: 'a;
++    pci_variance: (bool * bool) list;
++    pci_loc: Location.t }
++
++(* Value expressions for the core language *)
++
++type pattern =
++  { ppat_desc: pattern_desc;
++    ppat_loc: Location.t }
++
++and pattern_desc =
++    Ppat_any
++  | Ppat_var of string loc
++  | Ppat_alias of pattern * string loc
++  | Ppat_constant of constant
++  | Ppat_tuple of pattern list
++  | Ppat_construct of Longident.t loc * pattern option * bool
++  | Ppat_variant of label * pattern option
++  | Ppat_record of (Longident.t loc * pattern) list * closed_flag
++  | Ppat_array of pattern list
++  | Ppat_or of pattern * pattern
++  | Ppat_constraint of pattern * core_type
++  | Ppat_type of Longident.t loc
++  | Ppat_lazy of pattern
++  | Ppat_unpack of string loc
++
++type expression =
++  { pexp_desc: expression_desc;
++    pexp_loc: Location.t }
++
++and expression_desc =
++    Pexp_ident of Longident.t loc
++  | Pexp_constant of constant
++  | Pexp_let of rec_flag * (pattern * expression) list * expression
++  | Pexp_function of label * expression option * (pattern * expression) list
++  | Pexp_apply of expression * (label * expression) list
++  | Pexp_match of expression * (pattern * expression) list
++  | Pexp_try of expression * (pattern * expression) list
++  | Pexp_tuple of expression list
++  | Pexp_construct of Longident.t loc * expression option * bool
++  | Pexp_variant of label * expression option
++  | Pexp_record of (Longident.t loc * expression) list * expression option
++  | Pexp_field of expression * Longident.t loc
++  | Pexp_setfield of expression * Longident.t loc * expression
++  | Pexp_array of expression list
++  | Pexp_ifthenelse of expression * expression * expression option
++  | Pexp_sequence of expression * expression
++  | Pexp_while of expression * expression
++  | Pexp_for of string loc *  expression * expression * direction_flag * expression
++  | Pexp_constraint of expression * core_type option * core_type option
++  | Pexp_when of expression * expression
++  | Pexp_send of expression * string
++  | Pexp_new of Longident.t loc
++  | Pexp_setinstvar of string loc * expression
++  | Pexp_override of (string loc * expression) list
++  | Pexp_letmodule of string loc * module_expr * expression
++  | Pexp_assert of expression
++  | Pexp_assertfalse
++  | Pexp_lazy of expression
++  | Pexp_poly of expression * core_type option
++  | Pexp_object of class_structure
++  | Pexp_newtype of string * expression
++  | Pexp_pack of module_expr
++  | Pexp_open of Longident.t loc * expression
++
++(* Value descriptions *)
++
++and value_description =
++  { pval_type: core_type;
++    pval_prim: string list;
++    pval_loc : Location.t
++    }
++
++(* Type declarations *)
++
++and type_declaration =
++  { ptype_params: string loc option list;
++    ptype_cstrs: (core_type * core_type * Location.t) list;
++    ptype_kind: type_kind;
++    ptype_private: private_flag;
++    ptype_manifest: core_type option;
++    ptype_variance: (bool * bool) list;
++    ptype_loc: Location.t }
++
++and type_kind =
++    Ptype_abstract
++  | Ptype_variant of
++      (string loc * core_type list * core_type option * Location.t) list
++  | Ptype_record of
++      (string loc * mutable_flag * core_type * Location.t) list
++
++and exception_declaration = core_type list
++
++(* Type expressions for the class language *)
++
++and class_type =
++  { pcty_desc: class_type_desc;
++    pcty_loc: Location.t }
++
++and class_type_desc =
++    Pcty_constr of Longident.t loc * core_type list
++  | Pcty_signature of class_signature
++  | Pcty_fun of label * core_type * class_type
++
++and class_signature = {
++    pcsig_self : core_type;
++    pcsig_fields : class_type_field list;
++    pcsig_loc : Location.t;
++  }
++
++and class_type_field = {
++    pctf_desc : class_type_field_desc;
++    pctf_loc : Location.t;
++  }
++
++and class_type_field_desc =
++    Pctf_inher of class_type
++  | Pctf_val of (string * mutable_flag * virtual_flag * core_type)
++  | Pctf_virt  of (string * private_flag * core_type)
++  | Pctf_meth  of (string * private_flag * core_type)
++  | Pctf_cstr  of (core_type * core_type)
++
++and class_description = class_type class_infos
++
++and class_type_declaration = class_type class_infos
++
++(* Value expressions for the class language *)
++
++and class_expr =
++  { pcl_desc: class_expr_desc;
++    pcl_loc: Location.t }
++
++and class_expr_desc =
++    Pcl_constr of Longident.t loc * core_type list
++  | Pcl_structure of class_structure
++  | Pcl_fun of label * expression option * pattern * class_expr
++  | Pcl_apply of class_expr * (label * expression) list
++  | Pcl_let of rec_flag * (pattern * expression) list * class_expr
++  | Pcl_constraint of class_expr * class_type
++
++and class_structure = {
++    pcstr_pat : pattern;
++    pcstr_fields :  class_field list;
++  }
++
++and class_field = {
++    pcf_desc : class_field_desc;
++    pcf_loc : Location.t;
++  }
++
++and class_field_desc =
++    Pcf_inher of override_flag * class_expr * string option
++  | Pcf_valvirt of (string loc * mutable_flag * core_type)
++  | Pcf_val of (string loc * mutable_flag * override_flag * expression)
++  | Pcf_virt  of (string loc * private_flag * core_type)
++  | Pcf_meth of (string loc * private_flag *override_flag * expression)
++  | Pcf_constr  of (core_type * core_type)
++  | Pcf_init  of expression
++
++and class_declaration = class_expr class_infos
++
++(* Type expressions for the module language *)
++
++and module_type =
++  { pmty_desc: module_type_desc;
++    pmty_loc: Location.t }
++
++and module_type_desc =
++    Pmty_ident of Longident.t loc
++  | Pmty_signature of signature
++  | Pmty_functor of string loc * module_type * module_type
++  | Pmty_with of module_type * (Longident.t loc * with_constraint) list
++  | Pmty_typeof of module_expr
++
++and signature = signature_item list
++
++and signature_item =
++  { psig_desc: signature_item_desc;
++    psig_loc: Location.t }
++
++and signature_item_desc =
++    Psig_value of string loc * value_description
++  | Psig_type of (string loc * type_declaration) list
++  | Psig_exception of string loc * exception_declaration
++  | Psig_module of string loc * module_type
++  | Psig_recmodule of (string loc * module_type) list
++  | Psig_modtype of string loc * modtype_declaration
++  | Psig_open of Longident.t loc
++  | Psig_include of module_type
++  | Psig_class of class_description list
++  | Psig_class_type of class_type_declaration list
++
++and modtype_declaration =
++    Pmodtype_abstract
++  | Pmodtype_manifest of module_type
++
++and with_constraint =
++    Pwith_type of type_declaration
++  | Pwith_module of Longident.t loc
++  | Pwith_typesubst of type_declaration
++  | Pwith_modsubst of Longident.t loc
++
++(* Value expressions for the module language *)
++
++and module_expr =
++  { pmod_desc: module_expr_desc;
++    pmod_loc: Location.t }
++
++and module_expr_desc =
++    Pmod_ident of Longident.t loc
++  | Pmod_structure of structure
++  | Pmod_functor of string loc * module_type * module_expr
++  | Pmod_apply of module_expr * module_expr
++  | Pmod_constraint of module_expr * module_type
++  | Pmod_unpack of expression
++
++and structure = structure_item list
++
++and structure_item =
++  { pstr_desc: structure_item_desc;
++    pstr_loc: Location.t }
++
++and structure_item_desc =
++    Pstr_eval of expression
++  | Pstr_value of rec_flag * (pattern * expression) list
++  | Pstr_primitive of string loc * value_description
++  | Pstr_type of (string loc * type_declaration) list
++  | Pstr_exception of string loc * exception_declaration
++  | Pstr_exn_rebind of string loc * Longident.t loc
++  | Pstr_module of string loc * module_expr
++  | Pstr_recmodule of (string loc * module_type * module_expr) list
++  | Pstr_modtype of string loc * module_type
++  | Pstr_open of Longident.t loc
++  | Pstr_class of class_declaration list
++  | Pstr_class_type of class_type_declaration list
++  | Pstr_include of module_expr
++
++(* Toplevel phrases *)
++
++type toplevel_phrase =
++    Ptop_def of structure
++  | Ptop_dir of string * directive_argument
++
++and directive_argument =
++    Pdir_none
++  | Pdir_string of string
++  | Pdir_int of int
++  | Pdir_ident of Longident.t
++  | Pdir_bool of bool
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1 @@
++*.cm[oix]
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,2 @@
++pconfig.cmo: pconfig.cmi
++pconfig.cmx: pconfig.cmi
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,27 @@
++# Id
++
++FILES=warnings.cmi pconfig.cmo
++INCL=
++
++all: $(FILES)
++
++opt: pconfig.cmx
++
++clean:
++	rm -f *.cm[oix] *.o
++
++depend:
++	ocamldep $(INCL) *.ml* | sed -e 's/  *$$//' > .depend
++
++.SUFFIXES: .mli .cmi .ml .cmo .cmx
++
++.mli.cmi:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmo:
++	$(OCAMLN)c $(INCL) -c $<
++
++.ml.cmx:
++	$(OCAMLN)opt $(INCL) -c $<
++
++include .depend
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++let ocaml_version = "4.00.2"
++let ocaml_name = "ocaml"
++let ast_impl_magic_number = "Caml1999M015"
++let ast_intf_magic_number = "Caml1999N014"
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,4 @@
++val ocaml_version : string
++val ocaml_name : string
++val ast_impl_magic_number : string
++val ast_intf_magic_number : string
+diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli
+--- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli	2013-03-06 14:44:56.000000000 +0100
+@@ -0,0 +1,75 @@
++(***********************************************************************)
++(*                                                                     *)
++(*                                OCaml                                *)
++(*                                                                     *)
++(*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
++(*                                                                     *)
++(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
++(*  en Automatique.  All rights reserved.  This file is distributed    *)
++(*  under the terms of the Q Public License version 1.0.               *)
++(*                                                                     *)
++(***********************************************************************)
++
++(* Id *)
++
++open Format
++
++type t =
++  | Comment_start                           (*  1 *)
++  | Comment_not_end                         (*  2 *)
++  | Deprecated                              (*  3 *)
++  | Fragile_match of string                 (*  4 *)
++  | Partial_application                     (*  5 *)
++  | Labels_omitted                          (*  6 *)
++  | Method_override of string list          (*  7 *)
++  | Partial_match of string                 (*  8 *)
++  | Non_closed_record_pattern of string     (*  9 *)
++  | Statement_type                          (* 10 *)
++  | Unused_match                            (* 11 *)
++  | Unused_pat                              (* 12 *)
++  | Instance_variable_override of string list (* 13 *)
++  | Illegal_backslash                       (* 14 *)
++  | Implicit_public_methods of string list  (* 15 *)
++  | Unerasable_optional_argument            (* 16 *)
++  | Undeclared_virtual_method of string     (* 17 *)
++  | Not_principal of string                 (* 18 *)
++  | Without_principality of string          (* 19 *)
++  | Unused_argument                         (* 20 *)
++  | Nonreturning_statement                  (* 21 *)
++  | Camlp4 of string                        (* 22 *)
++  | Useless_record_with                     (* 23 *)
++  | Bad_module_name of string               (* 24 *)
++  | All_clauses_guarded                     (* 25 *)
++  | Unused_var of string                    (* 26 *)
++  | Unused_var_strict of string             (* 27 *)
++  | Wildcard_arg_to_constant_constr         (* 28 *)
++  | Eol_in_string                           (* 29 *)
++  | Duplicate_definitions of string * string * string * string (*30 *)
++  | Multiple_definition of string * string * string (* 31 *)
++  | Unused_value_declaration of string      (* 32 *)
++  | Unused_open of string                   (* 33 *)
++  | Unused_type_declaration of string       (* 34 *)
++  | Unused_for_index of string              (* 35 *)
++  | Unused_ancestor of string               (* 36 *)
++  | Unused_constructor of string * bool * bool  (* 37 *)
++  | Unused_exception of string * bool       (* 38 *)
++  | Unused_rec_flag                         (* 39 *)
++;;
++
++val parse_options : bool -> string -> unit;;
++
++val is_active : t -> bool;;
++val is_error : t -> bool;;
++
++val defaults_w : string;;
++val defaults_warn_error : string;;
++
++val print : formatter -> t -> int;;
++  (* returns the number of newlines in the printed string *)
++
++
++exception Errors of int;;
++
++val check_fatal : unit -> unit;;
++
++val help_warnings: unit -> unit
+diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml
+--- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml	1970-01-01 01:00:00.000000000 +0100
++++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml	2012-07-31 16:52:22.000000000 +0200
+@@ -0,0 +1,465 @@
++(* camlp5r pa_macro.cmo *)
++(* File generated by program: edit only if it does not compile. *)
++(* Copyright (c) INRIA 2007-2012 *)
++
++open Parsetree;;
++open Longident;;
++open Asttypes;;
++
++type ('a, 'b) choice =
++    Left of 'a
++  | Right of 'b
++;;
++
++let sys_ocaml_version = Sys.ocaml_version;;
++
++let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) =
++  let loc_at n lnum bolp =
++    {Lexing.pos_fname = if lnum = -1 then "" else fname;
++     Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n}
++  in
++  {Location.loc_start = loc_at bp lnum bolp;
++   Location.loc_end = loc_at ep lnuml bolpl;
++   Location.loc_ghost = bp = 0 && ep = 0}
++;;
++
++let loc_none =
++  let loc =
++    {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0;
++     Lexing.pos_cnum = -1}
++  in
++  {Location.loc_start = loc; Location.loc_end = loc;
++   Location.loc_ghost = true}
++;;
++
++let mkloc loc txt = {Location.txt = txt; Location.loc = loc};;
++let mknoloc txt = mkloc loc_none txt;;
++
++let ocaml_id_or_li_of_string_list loc sl =
++  let mkli s =
++    let rec loop f =
++      function
++        i :: il -> loop (fun s -> Ldot (f i, s)) il
++      | [] -> f s
++    in
++    loop (fun s -> Lident s)
++  in
++  match List.rev sl with
++    [] -> None
++  | s :: sl -> Some (mkli s (List.rev sl))
++;;
++
++let list_map_check f l =
++  let rec loop rev_l =
++    function
++      x :: l ->
++        begin match f x with
++          Some s -> loop (s :: rev_l) l
++        | None -> None
++        end
++    | [] -> Some (List.rev rev_l)
++  in
++  loop [] l
++;;
++
++let ocaml_value_description t p =
++  {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc}
++;;
++
++let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};;
++
++let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};;
++
++let ocaml_type_declaration params cl tk pf tm loc variance =
++  match list_map_check (fun s_opt -> s_opt) params with
++    Some params ->
++      let params = List.map (fun os -> Some (mknoloc os)) params in
++      Right
++        {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk;
++         ptype_private = pf; ptype_manifest = tm; ptype_loc = loc;
++         ptype_variance = variance}
++  | None -> Left "no '_' type param in this ocaml version"
++;;
++
++let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});;
++
++let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});;
++
++let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};;
++
++let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);;
++
++let ocaml_pmty_functor sloc s mt1 mt2 =
++  Pmty_functor (mkloc sloc s, mt1, mt2)
++;;
++
++let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);;
++
++let ocaml_pmty_with mt lcl =
++  let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl)
++;;
++
++let ocaml_ptype_abstract = Ptype_abstract;;
++
++let ocaml_ptype_record ltl priv =
++  Ptype_record
++    (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl)
++;;
++
++let ocaml_ptype_variant ctl priv =
++  try
++    let ctl =
++      List.map
++        (fun (c, tl, rto, loc) ->
++           if rto <> None then raise Exit else mknoloc c, tl, None, loc)
++        ctl
++    in
++    Some (Ptype_variant ctl)
++  with Exit -> None
++;;
++
++let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);;
++
++let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);;
++
++let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);;
++
++let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);;
++
++let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));;
++
++let ocaml_ptyp_variant catl clos sl_opt =
++  let catl =
++    List.map
++      (function
++         Left (c, a, tl) -> Rtag (c, a, tl)
++       | Right t -> Rinherit t)
++      catl
++  in
++  Some (Ptyp_variant (catl, clos, sl_opt))
++;;
++
++let ocaml_package_type li ltl =
++  mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl
++;;
++
++let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));;
++
++let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));;
++
++let ocaml_const_nativeint =
++  Some (fun s -> Const_nativeint (Nativeint.of_string s))
++;;
++
++let ocaml_pexp_apply f lel = Pexp_apply (f, lel);;
++
++let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;;
++
++let ocaml_pexp_assert fname loc e = Pexp_assert e;;
++
++let ocaml_pexp_construct li po chk_arity =
++  Pexp_construct (mknoloc li, po, chk_arity)
++;;
++
++let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);;
++
++let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);;
++
++let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);;
++
++let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);;
++
++let ocaml_pexp_ident li = Pexp_ident (mknoloc li);;
++
++let ocaml_pexp_letmodule =
++  Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e))
++;;
++
++let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);;
++
++let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));;
++
++let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);;
++
++let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));;
++
++let ocaml_pexp_override sel =
++  let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel
++;;
++
++let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));;
++
++let ocaml_pexp_record lel eo =
++  let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in
++  Pexp_record (lel, eo)
++;;
++
++let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);;
++
++let ocaml_pexp_variant =
++  let pexp_variant_pat =
++    function
++      Pexp_variant (lab, eo) -> Some (lab, eo)
++    | _ -> None
++  in
++  let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in
++  Some (pexp_variant_pat, pexp_variant)
++;;
++
++let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);;
++
++let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);;
++
++let ocaml_ppat_construct li li_loc po chk_arity =
++  Ppat_construct (mkloc li_loc li, po, chk_arity)
++;;
++
++let ocaml_ppat_construct_args =
++  function
++    Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity)
++  | _ -> None
++;;
++
++let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);;
++
++let ocaml_ppat_record lpl is_closed =
++  let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in
++  Ppat_record (lpl, (if is_closed then Closed else Open))
++;;
++
++let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));;
++
++let ocaml_ppat_unpack =
++  Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt))
++;;
++
++let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);;
++
++let ocaml_ppat_variant =
++  let ppat_variant_pat =
++    function
++      Ppat_variant (lab, po) -> Some (lab, po)
++    | _ -> None
++  in
++  let ppat_variant (lab, po) = Ppat_variant (lab, po) in
++  Some (ppat_variant_pat, ppat_variant)
++;;
++
++let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);;
++
++let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);;
++
++let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);;
++
++let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);;
++
++let ocaml_psig_open li = Psig_open (mknoloc li);;
++
++let ocaml_psig_recmodule =
++  let f ntl =
++    let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in
++    Psig_recmodule ntl
++  in
++  Some f
++;;
++
++let ocaml_psig_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl
++;;
++
++let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);;
++
++let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);;
++
++let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);;
++
++let ocaml_pstr_exn_rebind =
++  Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li))
++;;
++
++let ocaml_pstr_include = Some (fun me -> Pstr_include me);;
++
++let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);;
++
++let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);;
++
++let ocaml_pstr_open li = Pstr_open (mknoloc li);;
++
++let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);;
++
++let ocaml_pstr_recmodule =
++  let f nel =
++    Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel)
++  in
++  Some f
++;;
++
++let ocaml_pstr_type stl =
++  let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl
++;;
++
++let ocaml_class_infos =
++  Some
++    (fun virt (sl, sloc) name expr loc variance ->
++       let params = List.map (fun s -> mkloc loc s) sl, sloc in
++       {pci_virt = virt; pci_params = params; pci_name = mkloc loc name;
++        pci_expr = expr; pci_loc = loc; pci_variance = variance})
++;;
++
++let ocaml_pmod_ident li = Pmod_ident (mknoloc li);;
++
++let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);;
++
++let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option =
++  Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt)))
++;;
++
++let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));;
++
++let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);;
++
++let ocaml_pcf_init = Some (fun e -> Pcf_init e);;
++
++let ocaml_pcf_meth (s, pf, ovf, e, loc) =
++  let pf = if pf then Private else Public in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_meth (mkloc loc s, pf, ovf, e)
++;;
++
++let ocaml_pcf_val (s, mf, ovf, e, loc) =
++  let mf = if mf then Mutable else Immutable in
++  let ovf = if ovf then Override else Fresh in
++  Pcf_val (mkloc loc s, mf, ovf, e)
++;;
++
++let ocaml_pcf_valvirt =
++  let ocaml_pcf (s, mf, t, loc) =
++    let mf = if mf then Mutable else Immutable in
++    Pcf_valvirt (mkloc loc s, mf, t)
++  in
++  Some ocaml_pcf
++;;
++
++let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);;
++
++let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));;
++
++let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));;
++
++let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));;
++
++let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));;
++
++let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));;
++
++let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);;
++
++let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));;
++
++let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);;
++
++let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);;
++
++let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);;
++
++let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));;
++
++let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));;
++
++let ocaml_pcty_signature =
++  let f (t, ctfl) =
++    let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in
++    Pcty_signature cs
++  in
++  Some f
++;;
++
++let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);;
++
++let ocaml_pwith_modsubst =
++  Some (fun loc me -> Pwith_modsubst (mkloc loc me))
++;;
++
++let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);;
++
++let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);;
++
++let module_prefix_can_be_in_first_record_label_only = true;;
++
++let split_or_patterns_with_bindings = false;;
++
++let has_records_with_with = true;;
++
++(* *)
++
++let jocaml_pstr_def : (_ -> _) option = None;;
++
++let jocaml_pexp_def : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_par : (_ -> _ -> _) option = None;;
++
++let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;;
++
++let jocaml_pexp_spawn : (_ -> _) option = None;;
++
++let arg_rest =
++  function
++    Arg.Rest r -> Some r
++  | _ -> None
++;;
++
++let arg_set_string =
++  function
++    Arg.Set_string r -> Some r
++  | _ -> None
++;;
++
++let arg_set_int =
++  function
++    Arg.Set_int r -> Some r
++  | _ -> None
++;;
++
++let arg_set_float =
++  function
++    Arg.Set_float r -> Some r
++  | _ -> None
++;;
++
++let arg_symbol =
++  function
++    Arg.Symbol (s, f) -> Some (s, f)
++  | _ -> None
++;;
++
++let arg_tuple =
++  function
++    Arg.Tuple t -> Some t
++  | _ -> None
++;;
++
++let arg_bool =
++  function
++    Arg.Bool f -> Some f
++  | _ -> None
++;;
++
++let char_escaped = Char.escaped;;
++
++let hashtbl_mem = Hashtbl.mem;;
++
++let list_rev_append = List.rev_append;;
++
++let list_rev_map = List.rev_map;;
++
++let list_sort = List.sort;;
++
++let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;;
++
++let printf_ksprintf = Printf.ksprintf;;
++
++let string_contains = String.contains;;
diff --git a/testsuite/external/camlp5-6.10.patch b/testsuite/external/camlp5-6.10.patch
new file mode 100644
index 00000000..eeaf4c41
--- /dev/null
+++ b/testsuite/external/camlp5-6.10.patch
@@ -0,0 +1,10 @@
+--- camlp5-6.10.orig/ocaml_stuff/4.01.0/utils/warnings.mli	2013-06-19 04:17:42.000000000 +0200
++++ camlp5-6.10/ocaml_stuff/4.01.0/utils/warnings.mli	2013-08-13 16:14:47.000000000 +0200
+@@ -58,6 +58,7 @@
+   | Nonoptional_label of string             (* 43 *)
+   | Open_shadow_identifier of string * string (* 44 *)
+   | Open_shadow_label_constructor of string * string (* 45 *)
++  | Bad_env_variable of string * string
+ ;;
+ 
+ val parse_options : bool -> string -> unit;;
diff --git a/testsuite/external/camlpdf-0.5.patch b/testsuite/external/camlpdf-0.5.patch
new file mode 100644
index 00000000..e13ac339
--- /dev/null
+++ b/testsuite/external/camlpdf-0.5.patch
@@ -0,0 +1,25 @@
+--- camlpdf-0.5.orig/makefile	2010-03-08 17:30:19.000000000 +0100
++++ camlpdf-0.5/makefile	2013-05-30 17:07:12.000000000 +0200
+@@ -42,7 +42,7 @@
+ 
+ CLIBS = z
+ 
+-CFLAGS = -m32
++#CFLAGS = -m32
+ 
+ #Uncomment for debug build
+ #OCAMLNCFLAGS = -g
+@@ -56,6 +56,13 @@
+ #Remove native-code-library if you don't have native compilers
+ all : byte-code-library native-code-library
+ 
++LIBDIR="`ocamlc -where`"/camlpdf
++.PHONY: install
++install :
++	mkdir -p ${LIBDIR}
++	cp *.mli *.cm[ia] *.cmxa *.a *.so ${LIBDIR}/
++	cp introduction_to_camlpdf.pdf ${LIBDIR}/
++
+ # Predefined generic makefile
+ -include OCamlMakefile
+ 
diff --git a/testsuite/external/camlzip-1.04.patch b/testsuite/external/camlzip-1.04.patch
new file mode 100644
index 00000000..f49bc6a0
--- /dev/null
+++ b/testsuite/external/camlzip-1.04.patch
@@ -0,0 +1,45 @@
+--- camlzip-1.04/Makefile	2009-10-20 15:59:55.000000000 +0200
++++ camlzip-1.04/Makefile.new	2009-10-20 16:00:31.000000000 +0200
+@@ -4,10 +4,10 @@
+ ZLIB_LIB=-lz
+ 
+ # The directory containing the Zlib library (libz.a or libz.so)
+-ZLIB_LIBDIR=/usr/local/lib
++ZLIB_LIBDIR=/opt/local/lib
+ 
+ # The directory containing the Zlib header file (zlib.h)
+-ZLIB_INCLUDE=/usr/local/include
++ZLIB_INCLUDE=/opt/local/include
+ 
+ # Where to install the library.  By default: sub-directory 'zip' of
+ # OCaml's standard library directory.
+--- /dev/null	2009-10-20 16:35:40.000000000 +0200
++++ camlzip-1.04/META	2009-10-20 16:37:31.000000000 +0200
+@@ -0,0 +1,6 @@
++name = "camlzip"
++version = "1.04"
++description = "compression library"
++archive(byte) = "zip.cma"
++archive(native) = "zip.cmxa"
++directory = "+zip"
+--- camlzip-1.04/Makefile.orig	2011-07-04 18:09:00.000000000 +0200
++++ camlzip-1.04/Makefile	2011-07-04 18:10:09.000000000 +0200
+@@ -56,7 +56,8 @@
+ 
+ install:
+ 	mkdir -p $(INSTALLDIR)
+-	cp zip.cma zip.cmi gzip.cmi zip.mli gzip.mli libcamlzip.a $(INSTALLDIR)
++	cp zip.cma zip.cmi gzip.cmi zlib.cmi zip.mli gzip.mli zlib.mli \
++	   libcamlzip.a $(INSTALLDIR)
+ 	if test -f dllcamlzip.so; then \
+ 	  cp dllcamlzip.so $(INSTALLDIR); \
+           ldconf=`$(OCAMLC) -where`/ld.conf; \
+@@ -66,7 +67,7 @@
+         fi
+ 
+ installopt:
+-	cp zip.cmxa zip.a zip.cmx gzip.cmx $(INSTALLDIR)
++	cp zip.cmxa zip.a zip.cmx gzip.cmx zlib.cmx $(INSTALLDIR)
+ 
+ depend:
+ 	gcc -MM -I$(ZLIB_INCLUDE) *.c > .depend
diff --git a/testsuite/external/coq-8.3pl4.patch b/testsuite/external/coq-8.3pl4.patch
new file mode 100644
index 00000000..310510a5
--- /dev/null
+++ b/testsuite/external/coq-8.3pl4.patch
@@ -0,0 +1,59 @@
+--- coq-8.3pl4.orig/configure	2011-12-19 22:57:30.000000000 +0100
++++ coq-8.3pl4/configure	2012-03-16 11:44:55.000000000 +0100
+@@ -444,7 +444,7 @@
+ 
+ if [ "$coq_debug_flag" = "-g" ]; then
+     case $CAMLTAG in
+-        OCAML31*)
++        OCAML31*|OCAML4*)
+             # Compilation debug flag
+             coq_debug_flag_opt="-g"
+             ;;
+@@ -494,7 +494,7 @@
+     camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'`
+ else
+     case $CAMLTAG in
+-        OCAML31*)
++        OCAML31*|OCAML4*)
+             if [ -x "${CAMLLIB}/camlp5" ]; then
+                 CAMLP4LIB=+camlp5
+             elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then
+@@ -538,7 +538,7 @@
+       CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+       if [ "`uname -s`" = "Darwin" -a "$ARCH" = "i386" ]; then
+ 	  case $CAMLOPTVERSION in
+-	      3.09.3|3.1?*) ;;
++	      3.09.3|3.1?*|4.*) ;;
+ 	      *) echo "Native compilation on MacOS X Pentium requires Objective-Caml >= 3.09.3,"
+ 		 best_compiler=byte
+ 		 echo "only the bytecode version of Coq will be available."
+--- coq-8.3pl4/scripts/coqmktop.ml.orig	2012-05-26 21:32:12.000000000 +0200
++++ coq-8.3pl4/scripts/coqmktop.ml	2012-05-26 21:36:35.000000000 +0200
+@@ -63,6 +63,7 @@
+       (src_dirs ())
+       (["-I"; "\"" ^ camlp4lib ^ "\""] @
+ 	 ["-I"; "\"" ^ coqlib ^ "\""] @
++         ["-I"; "+compiler-libs"] @
+ 	 (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
+ 
+ (* Transform bytecode object file names in native object file names *)
+@@ -274,7 +275,7 @@
+         ocamloptexec^" -linkall"
+     end else
+       (* bytecode (we shunt ocamlmktop script which fails on win32) *)
+-      let ocamlmktoplib = " toplevellib.cma" in
++      let ocamlmktoplib = " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma" in
+       let ocamlcexec = Filename.concat camlbin "ocamlc" in
+       let ocamlccustom = Printf.sprintf "%s %s -linkall "
+         ocamlcexec Coq_config.coqrunbyteflags in
+--- coq-8.3pl4/configure.orig	2012-07-18 11:31:08.353180800 +0200
++++ coq-8.3pl4/configure	2012-07-18 11:31:10.346046400 +0200
+@@ -272,7 +272,7 @@
+     no) 
+     # First we test if we are running a Cygwin system
+     if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then
+-	ARCH="win32"
++	ARCH=`uname -s`
+     else
+ 	# If not, we determine the architecture
+ 	if test -x /bin/arch ; then
diff --git a/testsuite/external/core-109.37.00.patch b/testsuite/external/core-109.37.00.patch
new file mode 100644
index 00000000..53e443ee
--- /dev/null
+++ b/testsuite/external/core-109.37.00.patch
@@ -0,0 +1,20 @@
+--- core-109.37.00.orig/lib/core_unix.ml	2013-08-06 21:52:16.000000000 +0200
++++ core-109.37.00/lib/core_unix.ml	2013-08-13 15:25:11.000000000 +0200
+@@ -890,6 +890,7 @@
+ | O_SYNC
+ | O_RSYNC
+ | O_SHARE_DELETE
++| O_CLOEXEC
+ with sexp
+ 
+ type file_perm = int with of_sexp
+--- core-109.37.00.orig/lib/core_unix.mli	2013-08-06 21:52:16.000000000 +0200
++++ core-109.37.00/lib/core_unix.mli	2013-08-13 15:25:32.000000000 +0200
+@@ -305,6 +305,7 @@
+     | O_SYNC          (** Writes complete as `Synchronised I/O file integrity completion' *)
+     | O_RSYNC         (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+     | O_SHARE_DELETE  (** Windows only: allow the file to be deleted while still open *)
++    | O_CLOEXEC
+ with sexp
+ 
+ (** The type of file access rights. *)
diff --git a/testsuite/external/core-suite-108.00.01.patch b/testsuite/external/core-suite-108.00.01.patch
new file mode 100644
index 00000000..4c454aa8
--- /dev/null
+++ b/testsuite/external/core-suite-108.00.01.patch
@@ -0,0 +1,213 @@
+--- core-suite-108.00.01.orig/sexplib-108.00.01/top/install_printers.ml	2012-05-14 20:53:09.000000000 +0200
++++ core-suite-108.00.01/sexplib-108.00.01/top/install_printers.ml	2012-07-12 17:33:45.000000000 +0200
+@@ -3,8 +3,11 @@
+ let eval_string
+       ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str =
+   let lexbuf = Lexing.from_string str in
++assert false
++(*
+   let phrase = !Toploop.parse_toplevel_phrase lexbuf in
+   Toploop.execute_phrase print_outcome err_formatter phrase
++*)
+ 
+ let rec install_printers = function
+   | [] -> true
+--- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.mli	2012-05-25 23:10:12.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/lib/core_unix.mli	2012-07-12 17:39:29.000000000 +0200
+@@ -296,6 +296,7 @@
+     | O_DSYNC      (** Writes complete as `Synchronised I/O data integrity completion' *)
+     | O_SYNC       (** Writes complete as `Synchronised I/O file integrity completion' *)
+     | O_RSYNC      (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
++    | O_SHARE_DELETE
+ with sexp
+ 
+ (** The type of file access rights. *)
+--- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.ml	2012-05-25 23:10:12.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/lib/core_unix.ml	2012-07-12 17:44:04.000000000 +0200
+@@ -804,6 +804,7 @@
+ | O_DSYNC
+ | O_SYNC
+ | O_RSYNC
++| O_SHARE_DELETE
+ with sexp
+ 
+ type file_perm = int with of_sexp
+--- core-suite-108.00.01.orig/core-108.00.01/top/install_printers.ml	2012-05-17 16:50:03.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/top/install_printers.ml	2012-07-12 17:48:36.000000000 +0200
+@@ -5,8 +5,11 @@
+ let eval_string
+       ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str =
+   let lexbuf = Lexing.from_string str in
++assert false
++(*
+   let phrase = !Toploop.parse_toplevel_phrase lexbuf in
+   Toploop.execute_phrase print_outcome err_formatter phrase
++*)
+ 
+ let rec install_printers = function
+   | [] -> true
+--- core-suite-108.00.01.orig/async-108.00.01/myocamlbuild.ml	2012-05-26 00:48:10.000000000 +0200
++++ core-suite-108.00.01/async-108.00.01/myocamlbuild.ml	2012-07-12 17:59:01.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_core-108.00.01/myocamlbuild.ml	2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_core-108.00.01/myocamlbuild.ml	2012-07-12 17:58:57.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_extra-108.00.01/myocamlbuild.ml	2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_extra-108.00.01/myocamlbuild.ml	2012-07-12 17:58:53.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/async_unix-108.00.01/myocamlbuild.ml	2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/async_unix-108.00.01/myocamlbuild.ml	2012-07-12 17:58:48.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/bin_prot-108.00.01/myocamlbuild.ml	2012-05-26 00:48:07.000000000 +0200
++++ core-suite-108.00.01/bin_prot-108.00.01/myocamlbuild.ml	2012-07-12 17:15:41.000000000 +0200
+@@ -636,7 +636,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ (* We probably will want to set this up in the `configure` script at some
+--- core-suite-108.00.01.orig/comparelib-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/comparelib-108.00.01/myocamlbuild.ml	2012-07-12 17:58:40.000000000 +0200
+@@ -631,7 +631,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/core-108.00.01/myocamlbuild.ml	2012-05-26 00:48:08.000000000 +0200
++++ core-suite-108.00.01/core-108.00.01/myocamlbuild.ml	2012-07-12 17:35:18.000000000 +0200
+@@ -643,7 +643,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/core_extended-108.00.01/myocamlbuild.ml	2012-05-26 00:48:09.000000000 +0200
++++ core-suite-108.00.01/core_extended-108.00.01/myocamlbuild.ml	2012-07-12 17:51:57.000000000 +0200
+@@ -645,7 +645,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/fieldslib-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/fieldslib-108.00.01/myocamlbuild.ml	2012-07-12 17:07:50.000000000 +0200
+@@ -631,7 +631,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/pa_ounit-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/pa_ounit-108.00.01/myocamlbuild.ml	2012-07-12 17:13:58.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/pipebang-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/pipebang-108.00.01/myocamlbuild.ml	2012-07-12 17:58:22.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/sexplib-108.00.01/myocamlbuild.ml	2012-05-26 00:48:07.000000000 +0200
++++ core-suite-108.00.01/sexplib-108.00.01/myocamlbuild.ml	2012-07-12 17:24:42.000000000 +0200
+@@ -635,7 +635,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence"])
+ ;;
+ 
+ Ocamlbuild_plugin.dispatch
+--- core-suite-108.00.01.orig/type_conv-108.00.01/myocamlbuild.ml	2012-05-26 00:48:05.000000000 +0200
++++ core-suite-108.00.01/type_conv-108.00.01/myocamlbuild.ml	2012-07-12 17:05:31.000000000 +0200
+@@ -630,7 +630,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/typehashlib-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/typehashlib-108.00.01/myocamlbuild.ml	2012-07-12 17:58:06.000000000 +0200
+@@ -631,7 +631,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
+--- core-suite-108.00.01.orig/variantslib-108.00.01/myocamlbuild.ml	2012-05-26 00:48:06.000000000 +0200
++++ core-suite-108.00.01/variantslib-108.00.01/myocamlbuild.ml	2012-07-12 17:11:51.000000000 +0200
+@@ -631,7 +631,7 @@
+       List.concat (List.map f flags)
+     in
+     flag ["compile"; "c"] (S cflags);
+-    flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ])
++    flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
+ ;;
+ 
+ let dispatch = function
diff --git a/testsuite/external/extlib-1.5.2.patch b/testsuite/external/extlib-1.5.2.patch
new file mode 100644
index 00000000..56e48b12
--- /dev/null
+++ b/testsuite/external/extlib-1.5.2.patch
@@ -0,0 +1,10 @@
+--- extlib-1.5.2.orig/extHashtbl.ml	2011-08-06 16:56:39.000000000 +0200
++++ extlib-1.5.2/extHashtbl.ml	2012-01-12 19:48:28.000000000 +0100
+@@ -32,6 +32,7 @@
+ 	}
+ 
+ 	include Hashtbl
++        let create n = Hashtbl.create (* no seed *) n
+ 
+ 	external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity"
+ 	external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity"
diff --git a/testsuite/external/frama-c-Nitrogen-20111001.patch b/testsuite/external/frama-c-Nitrogen-20111001.patch
new file mode 100644
index 00000000..f7fc2972
--- /dev/null
+++ b/testsuite/external/frama-c-Nitrogen-20111001.patch
@@ -0,0 +1,126 @@
+diff -r -u frama-c-Nitrogen-20111001.orig/src/type/datatype.mli frama-c-Nitrogen-20111001/src/type/datatype.mli
+--- frama-c-Nitrogen-20111001.orig/src/type/datatype.mli	2011-10-10 10:38:09.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/type/datatype.mli	2012-01-05 18:35:45.000000000 +0100
+@@ -249,10 +249,27 @@
+ 
+ end
+ 
++module type Hashtbl_S = sig
++    type key
++    type 'a t
++    val create : int -> 'a t
++    val clear : 'a t -> unit
++    val copy : 'a t -> 'a t
++    val add : 'a t -> key -> 'a -> unit
++    val remove : 'a t -> key -> unit
++    val find : 'a t -> key -> 'a
++    val find_all : 'a t -> key -> 'a list
++    val replace : 'a t -> key -> 'a -> unit
++    val mem : 'a t -> key -> bool
++    val iter : (key -> 'a -> unit) -> 'a t -> unit
++    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
++    val length : 'a t -> int
++end
++
+ (** A standard OCaml hashtbl signature extended with datatype operations. *)
+ module type Hashtbl = sig
+ 
+-  include Hashtbl.S
++  include Hashtbl_S
+ 
+   val memo: 'a t -> key -> (key -> 'a) -> 'a
+   (** [memo tbl k f] returns the binding of [k] in [tbl]. If there is
+@@ -468,7 +485,7 @@
+ module Map(M: Map_common_interface.S)(Key: S with type t = M.key)(Info: Functor_info) :
+   Map with type 'a t = 'a M.t and type key = M.key and module Key = Key
+ 
+-module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info):
++module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info):
+   Hashtbl with type 'a t = 'a H.t and type key = H.key and module Key = Key
+ 
+ module type Sub_caml_weak_hashtbl = sig
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli frama-c-Nitrogen-20111001/src/wp/LogicId.mli
+--- frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli	2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/LogicId.mli	2012-01-05 18:38:36.000000000 +0100
+@@ -40,7 +40,7 @@
+ 
+ module Iset : Set.S with type elt = t
+ module Imap : Map.S with type key = t
+-module Ihmap : Hashtbl.S with type key = t
++module Ihmap : Datatype.Hashtbl_S with type key = t
+ 
+ (** {3 Name Spaces} *)
+ 
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml frama-c-Nitrogen-20111001/src/wp/fol_formula.ml
+--- frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml	2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/fol_formula.ml	2012-01-05 18:31:40.000000000 +0100
+@@ -389,7 +389,7 @@
+ module type Identifiable =
+ sig
+   type t
+-  module H : Hashtbl.S
++  module H : Datatype.Hashtbl_S
+   val index : t -> H.key
+   val prefix : string
+   val basename : t -> string
+diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/formula.mli frama-c-Nitrogen-20111001/src/wp/formula.mli
+--- frama-c-Nitrogen-20111001.orig/src/wp/formula.mli	2011-10-10 10:38:21.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/wp/formula.mli	2012-01-05 18:38:28.000000000 +0100
+@@ -147,7 +147,7 @@
+   module type Identifiable =
+   sig
+     type t
+-    module H : Hashtbl.S
++    module H : Datatype.Hashtbl_S
+     val index : t -> H.key
+     val prefix : string
+     val basename : t -> string
+--- frama-c-Nitrogen-20111001.orig/src/type/datatype.ml	2011-10-10 10:38:09.000000000 +0200
++++ frama-c-Nitrogen-20111001/src/type/datatype.ml	2012-01-05 18:46:38.000000000 +0100
+@@ -306,8 +306,26 @@
+   module Make(Data: S) : S with type t = Data.t t
+ end
+ 
++module type Hashtbl_S =
++  sig
++    type key
++    type 'a t
++    val create : int -> 'a t
++    val clear : 'a t -> unit
++    val copy : 'a t -> 'a t
++    val add : 'a t -> key -> 'a -> unit
++    val remove : 'a t -> key -> unit
++    val find : 'a t -> key -> 'a
++    val find_all : 'a t -> key -> 'a list
++    val replace : 'a t -> key -> 'a -> unit
++    val mem : 'a t -> key -> bool
++    val iter : (key -> 'a -> unit) -> 'a t -> unit
++    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
++    val length : 'a t -> int
++  end
++
+ module type Hashtbl = sig
+-  include Hashtbl.S
++  include Hashtbl_S
+   val memo: 'a t -> key -> (key -> 'a) -> 'a
+   module Key: S with type t = key
+   module Make(Data: S) : S with type t = Data.t t
+@@ -970,7 +988,7 @@
+ module Initial_caml_hashtbl = Hashtbl
+ 
+ (* ocaml functors are generative *)
+-module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info) =
++module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info) =
+ struct
+ 
+   let () = check Key.equal "equal" Key.name Info.module_name
+--- frama-c-Nitrogen-20111001/configure.orig	2012-03-12 16:14:45.000000000 +0100
++++ frama-c-Nitrogen-20111001/configure	2012-03-12 16:15:06.000000000 +0100
+@@ -2675,6 +2675,7 @@
+          ;;
+   3.10*) echo "${ECHO_T}good!";;
+   3.1*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";;
++  4.0*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";;
+   *) echo "${ECHO_T}Incompatible version!"; exit 2;;
+ esac
+ 
diff --git a/testsuite/external/frama-c-Oxygen-20120901.patch b/testsuite/external/frama-c-Oxygen-20120901.patch
new file mode 100644
index 00000000..2f3ce3e6
--- /dev/null
+++ b/testsuite/external/frama-c-Oxygen-20120901.patch
@@ -0,0 +1,185 @@
+--- frama-c-Oxygen-20120901.orig/src/type/datatype.ml	2012-09-19 13:55:23.000000000 +0200
++++ frama-c-Oxygen-20120901/src/type/datatype.ml	2013-02-19 16:36:36.000000000 +0100
+@@ -285,8 +285,37 @@
+ 
+ end
+ 
++module type Set_S = sig
++    type elt
++    type t
++    val empty: t
++    val is_empty: t -> bool
++    val mem: elt -> t -> bool
++    val add: elt -> t -> t
++    val singleton: elt -> t
++    val remove: elt -> t -> t
++    val union: t -> t -> t
++    val inter: t -> t -> t
++    val diff: t -> t -> t
++    val compare: t -> t -> int
++    val equal: t -> t -> bool
++    val subset: t -> t -> bool
++    val iter: (elt -> unit) -> t -> unit
++    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++    val for_all: (elt -> bool) -> t -> bool
++    val exists: (elt -> bool) -> t -> bool
++    val filter: (elt -> bool) -> t -> t
++    val partition: (elt -> bool) -> t -> t * t
++    val cardinal: t -> int
++    val elements: t -> elt list
++    val min_elt: t -> elt
++    val max_elt: t -> elt
++    val choose: t -> elt
++    val split: elt -> t -> t * bool * t
++end
++
+ module type Set = sig
+-  include Set.S
++  include Set_S
+   val ty: t Type.t
+   val name: string
+   val descr: t Descr.t
+@@ -1093,7 +1122,7 @@
+ module Initial_caml_set = Set
+ 
+ (* ocaml functors are generative *)
+-module Set(S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) = struct
++module Set(S: Set_S)(E: S with type t = S.elt)(Info: Functor_info) = struct
+ 
+   let () = check E.equal "equal" E.name Info.module_name
+   let () = check E.compare "compare" E.name Info.module_name
+--- frama-c-Oxygen-20120901.orig/src/type/datatype.mli	2012-09-19 13:55:23.000000000 +0200
++++ frama-c-Oxygen-20120901/src/type/datatype.mli	2013-02-19 16:36:29.000000000 +0100
+@@ -230,9 +230,38 @@
+     defining by applying the functor. *)
+ end
+ 
++module type Set_S = sig
++    type elt
++    type t
++    val empty: t
++    val is_empty: t -> bool
++    val mem: elt -> t -> bool
++    val add: elt -> t -> t
++    val singleton: elt -> t
++    val remove: elt -> t -> t
++    val union: t -> t -> t
++    val inter: t -> t -> t
++    val diff: t -> t -> t
++    val compare: t -> t -> int
++    val equal: t -> t -> bool
++    val subset: t -> t -> bool
++    val iter: (elt -> unit) -> t -> unit
++    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++    val for_all: (elt -> bool) -> t -> bool
++    val exists: (elt -> bool) -> t -> bool
++    val filter: (elt -> bool) -> t -> t
++    val partition: (elt -> bool) -> t -> t * t
++    val cardinal: t -> int
++    val elements: t -> elt list
++    val min_elt: t -> elt
++    val max_elt: t -> elt
++    val choose: t -> elt
++    val split: elt -> t -> t * bool * t
++end
++
+ (** A standard OCaml set signature extended with datatype operations. *)
+ module type Set = sig
+-  include Set.S
++  include Set_S
+   val ty: t Type.t
+   val name: string
+   val descr: t Descr.t
+@@ -602,7 +631,7 @@
+   'e Type.t ->
+   ('a -> 'b -> 'c -> 'd -> 'e) Type.t
+ 
+-module Set(S: Set.S)(E: S with type t = S.elt)(Info : Functor_info):
++module Set(S: Set_S)(E: S with type t = S.elt)(Info : Functor_info):
+   Set with type t = S.t and type elt = E.t
+ 
+ module Map
+--- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.ml	2012-09-19 13:55:28.000000000 +0200
++++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.ml	2013-02-19 16:45:08.000000000 +0100
+@@ -20,9 +20,38 @@
+ (*                                                                        *)
+ (**************************************************************************)
+ 
++module type Set_S = sig
++    type elt
++    type t
++    val empty: t
++    val is_empty: t -> bool
++    val mem: elt -> t -> bool
++    val add: elt -> t -> t
++    val singleton: elt -> t
++    val remove: elt -> t -> t
++    val union: t -> t -> t
++    val inter: t -> t -> t
++    val diff: t -> t -> t
++    val compare: t -> t -> int
++    val equal: t -> t -> bool
++    val subset: t -> t -> bool
++    val iter: (elt -> unit) -> t -> unit
++    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++    val for_all: (elt -> bool) -> t -> bool
++    val exists: (elt -> bool) -> t -> bool
++    val filter: (elt -> bool) -> t -> t
++    val partition: (elt -> bool) -> t -> t * t
++    val cardinal: t -> int
++    val elements: t -> elt list
++    val min_elt: t -> elt
++    val max_elt: t -> elt
++    val choose: t -> elt
++    val split: elt -> t -> t * bool * t
++end
++
+ module type S =
+ sig
+-  include Set.S
++  include Set_S
+   val map : (elt -> elt) -> t -> t
+   val intersect : t -> t -> bool
+ end
+--- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.mli	2012-09-19 13:55:28.000000000 +0200
++++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.mli	2013-02-19 16:45:19.000000000 +0100
+@@ -22,9 +22,38 @@
+ 
+ (** Set of indexed elements implemented as Patricia sets. *)
+ 
++module type Set_S = sig
++    type elt
++    type t
++    val empty: t
++    val is_empty: t -> bool
++    val mem: elt -> t -> bool
++    val add: elt -> t -> t
++    val singleton: elt -> t
++    val remove: elt -> t -> t
++    val union: t -> t -> t
++    val inter: t -> t -> t
++    val diff: t -> t -> t
++    val compare: t -> t -> int
++    val equal: t -> t -> bool
++    val subset: t -> t -> bool
++    val iter: (elt -> unit) -> t -> unit
++    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
++    val for_all: (elt -> bool) -> t -> bool
++    val exists: (elt -> bool) -> t -> bool
++    val filter: (elt -> bool) -> t -> t
++    val partition: (elt -> bool) -> t -> t * t
++    val cardinal: t -> int
++    val elements: t -> elt list
++    val min_elt: t -> elt
++    val max_elt: t -> elt
++    val choose: t -> elt
++    val split: elt -> t -> t * bool * t
++end
++
+ module type S =
+ sig
+-  include Set.S
++  include Set_S
+   val map : (elt -> elt) -> t -> t
+   val intersect : t -> t -> bool
+ end
diff --git a/testsuite/external/hevea-1.10.patch b/testsuite/external/hevea-1.10.patch
new file mode 100644
index 00000000..40aab2b7
--- /dev/null
+++ b/testsuite/external/hevea-1.10.patch
@@ -0,0 +1,22 @@
+diff -r -u hevea-1.10 2/hevea.ml hevea-1.10/hevea.ml
+--- hevea-1.10 2/hevea.ml	2007-02-09 15:44:28.000000000 +0100
++++ hevea-1.10/hevea.ml	2009-08-27 17:51:55.000000000 +0200
+@@ -237,6 +237,7 @@
+ *)
+   end ;
+   let _ = finalize false in
++  begin try Sys.remove Parse_opts.name_out with _ -> () end;
+   prerr_endline "Adios" ;
+   exit 2
+ ;;
+--- hevea-1.10/Makefile.orig	2009-10-28 12:18:16.000000000 +0100
++++ hevea-1.10/Makefile	2009-10-28 12:18:00.000000000 +0100
+@@ -48,7 +48,7 @@
+ all-make: $(TARGET)-make
+ 
+ install: config.sh
+-	./install.sh $(TARGET)
++	LIBDIR=${LIBDIR} LATEXLIBDIR=${LATEXLIBDIR} ./install.sh $(TARGET)
+ 
+ byte: ocb-byte
+ opt: ocb-opt
diff --git a/testsuite/external/kaputt-1.2.patch b/testsuite/external/kaputt-1.2.patch
new file mode 100644
index 00000000..279730ed
--- /dev/null
+++ b/testsuite/external/kaputt-1.2.patch
@@ -0,0 +1,37 @@
+--- kaputt-1.2/src/syntax/kaputt_pp.ml.orig	2012-12-19 16:46:36.000000000 +0100
++++ kaputt-1.2/src/syntax/kaputt_pp.ml	2012-12-19 16:46:59.000000000 +0100
+@@ -54,6 +54,8 @@
+       let temp_name, temp_chan = Filename.open_temp_file "kaputt" ".ml" in
+       let source_chan = open_in args.(len - 3) in
+       let test_chan = open_in test_file in
++      let directive = Printf.sprintf "# 1 %S\n" args.(len - 3) in
++      output_string temp_chan directive;
+       copy source_chan temp_chan;
+       let directive = Printf.sprintf "# 1 %S\n" test_file in
+       output_string temp_chan directive;
+--- kaputt-1.2/src/syntax/kaputt_pp.ml.orig	2013-01-08 17:05:01.000000000 +0100
++++ kaputt-1.2/src/syntax/kaputt_pp.ml	2013-01-08 17:05:46.000000000 +0100
+@@ -28,8 +28,7 @@
+     Buffer.add_string buff (quote args.(i));
+     Buffer.add_char buff ' ';
+   done;
+-  let code = Sys.command (Buffer.contents buff) in
+-  ignore (exit code)
++  Sys.command (Buffer.contents buff)
+ 
+ let copy from_chan to_chan =
+   try
+@@ -64,9 +63,11 @@
+       close_in_noerr test_chan;
+       close_out_noerr temp_chan;
+       args.(len - 3) <- temp_name;
+-      call args
++      let code = call args in
++      (try Sys.remove temp_name with _ -> ());
++      ignore (exit code)
+     end else begin
+-      call args
++      ignore (exit (call args))
+     end
+   else begin
+     Printf.eprintf "Error: invalid command-line\n";
diff --git a/testsuite/external/lablgtk-2.14.2.patch b/testsuite/external/lablgtk-2.14.2.patch
new file mode 100644
index 00000000..4824726a
--- /dev/null
+++ b/testsuite/external/lablgtk-2.14.2.patch
@@ -0,0 +1,11 @@
+--- lablgtk-2.14.2/src/Makefile.orig	2012-07-31 17:37:12.000000000 +0200
++++ lablgtk-2.14.2/src/Makefile	2012-07-31 17:37:17.000000000 +0200
+@@ -191,7 +191,7 @@
+ .ml4.cmo:
+ 	$(CAMLC) -c -pp "$(CAMLP4O) -impl" -impl $<
+ .cmxa.cmxs:
+-	$(CAMLOPT) -verbose -o $@ -shared -linkall -I . \
++	$(CAMLOPT) -o $@ -shared -linkall -I . \
+         -ccopt '$(filter -L%, $(DYNLINKLIBS))' $<
+ 
+ #.ml4.ml:
diff --git a/testsuite/external/lablgtk-2.16.0.patch b/testsuite/external/lablgtk-2.16.0.patch
new file mode 100644
index 00000000..c16e10cc
--- /dev/null
+++ b/testsuite/external/lablgtk-2.16.0.patch
@@ -0,0 +1,22 @@
+--- lablgtk-2.16.0.orig/src/gMenu.ml	2012-08-23 12:37:48.000000000 +0200
++++ lablgtk-2.16.0/src/gMenu.ml	2013-02-18 20:12:27.000000000 +0100
+@@ -87,7 +87,7 @@
+ 
+ class menu_item_skel = [menu_item] pre_menu_item_skel
+ 
+-let pack_item self ~packing ~show =
++let pack_item self ?packing ?show =
+   may packing ~f:(fun f -> (f (self :> menu_item) : unit));
+   if show <> Some false then self#misc#show ();
+   self
+--- lablgtk-2.16.0.orig/src/gFile.ml	2012-08-23 12:37:48.000000000 +0200
++++ lablgtk-2.16.0/src/gFile.ml	2013-02-18 20:13:37.000000000 +0100
+@@ -179,7 +179,7 @@
+ 	 FileChooser.P.file_system_backend backend
+ 	 [ Gobject.param FileChooser.P.action action ]) in
+   let o = new chooser_widget w in
+-  GObj.pack_return o ?packing ?show
++  GObj.pack_return o ~packing ~show
+ 
+ class chooser_button_signals obj = object
+   inherit GContainer.container_signals_impl obj
diff --git a/testsuite/external/lablgtkextras-1.1.patch b/testsuite/external/lablgtkextras-1.1.patch
new file mode 100644
index 00000000..19acf21d
--- /dev/null
+++ b/testsuite/external/lablgtkextras-1.1.patch
@@ -0,0 +1,22 @@
+--- lablgtkextras-1.1.orig/checkocaml.ml	2012-04-13 16:51:37.000000000 +0200
++++ lablgtkextras-1.1/checkocaml.ml	2012-05-25 16:23:36.000000000 +0200
+@@ -885,7 +885,7 @@
+ let _ = !print "\n### checking required tools and libraries ###\n"
+ 
+ let () = check_ocamlfind_package conf "config-file";;
+-let () = check_ocamlfind_package conf "lablgtk2.sourceview2";;
++let () = check_ocamlfind_package conf "lablgtk2";;
+ let () = check_ocamlfind_package conf ~min_version: [1;1] "xmlm";;
+ 
+ let _ = !print "\n###\n"
+--- lablgtkextras-1.1.orig/src/Makefile	2012-04-13 16:51:37.000000000 +0200
++++ lablgtkextras-1.1/src/Makefile	2012-05-25 16:27:58.000000000 +0200
+@@ -26,7 +26,7 @@
+ 
+ include ../master.Makefile
+ 
+-PACKAGES=config-file,lablgtk2.sourceview2,xmlm
++PACKAGES=config-file,lablgtk2,xmlm
+ OF_FLAGS= -package $(PACKAGES)
+ 
+ COMPFLAGS=-annot -g -warn-error A
diff --git a/testsuite/external/lablgtkextras-1.3.patch b/testsuite/external/lablgtkextras-1.3.patch
new file mode 100644
index 00000000..e36480fd
--- /dev/null
+++ b/testsuite/external/lablgtkextras-1.3.patch
@@ -0,0 +1,11 @@
+--- lablgtkextras-1.3/src/Makefile.orig	2013-05-29 14:21:34.000000000 +0200
++++ lablgtkextras-1.3/src/Makefile	2013-05-29 14:21:52.000000000 +0200
+@@ -29,7 +29,7 @@
+ PACKAGES=config-file,lablgtk2.sourceview2,xmlm
+ OF_FLAGS= -package $(PACKAGES)
+ 
+-COMPFLAGS=-annot -g -warn-error A
++COMPFLAGS=-annot -g -warn-error a
+ 
+ GELIB_CMOFILES= \
+ 	gtke_version.cmo \
diff --git a/testsuite/external/lwt-2.4.0.patch b/testsuite/external/lwt-2.4.0.patch
new file mode 100644
index 00000000..14ce097c
--- /dev/null
+++ b/testsuite/external/lwt-2.4.0.patch
@@ -0,0 +1,24 @@
+--- lwt-2.4.0.orig/src/unix/lwt_unix.ml	2012-07-19 13:35:56.000000000 +0200
++++ lwt-2.4.0/src/unix/lwt_unix.ml	2013-08-13 15:46:12.000000000 +0200
+@@ -596,6 +596,9 @@
+ #if ocaml_version >= (3, 13)
+   | O_SHARE_DELETE
+ #endif
++#if ocaml_version >= (4, 01)
++  | O_CLOEXEC
++#endif
+ 
+ #if windows
+ 
+--- lwt-2.4.0.orig/src/unix/lwt_unix.mli	2012-07-19 13:35:56.000000000 +0200
++++ lwt-2.4.0/src/unix/lwt_unix.mli	2013-08-13 15:46:18.000000000 +0200
+@@ -315,6 +315,9 @@
+ #if ocaml_version >= (3, 13)
+   | O_SHARE_DELETE
+ #endif
++#if ocaml_version >= (4, 01)
++  | O_CLOEXEC
++#endif
+ 
+ val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t
+   (** Wrapper for [Unix.openfile]. *)
diff --git a/testsuite/external/menhir-20120123.patch b/testsuite/external/menhir-20120123.patch
new file mode 100644
index 00000000..a6a83bdf
--- /dev/null
+++ b/testsuite/external/menhir-20120123.patch
@@ -0,0 +1,11 @@
+--- menhir-20120123/Makefile.arch.orig	2012-09-28 19:03:09.673811200 +0200
++++ menhir-20120123/Makefile.arch	2012-09-28 19:07:38.680344000 +0200
+@@ -1,7 +1,7 @@
+ # If ocaml reports that Sys.os_type is Unix, we assume Unix, otherwise
+ # we assume Windows.
+ 
+-ifeq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Unix"
++ifneq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Win32"
+ MENHIREXE    := menhir
+ OBJ          := o
+ else
diff --git a/testsuite/external/mldonkey-3.1.2.patch b/testsuite/external/mldonkey-3.1.2.patch
new file mode 100644
index 00000000..82d3edb2
--- /dev/null
+++ b/testsuite/external/mldonkey-3.1.2.patch
@@ -0,0 +1,31 @@
+--- mldonkey-3.1.2.orig/config/configure	2011-08-08 07:11:57.000000000 +0200
++++ mldonkey-3.1.2/config/configure	2012-03-13 12:52:40.000000000 +0100
+@@ -4870,7 +4870,7 @@
+ else
+   OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+   case "$OCAMLVERSION" in
+-    "$REQUIRED_OCAML"*|3.12.*|3.11.*|3.10.1*|3.10.2*) ;;
++    "$REQUIRED_OCAML"*|4.*|3.1[23].*|3.11.*|3.10.1*|3.10.2*) ;;
+     *)
+         echo "Need build"
+         BUILD_OCAML=yes
+@@ -5402,7 +5402,7 @@
+ 
+ # force usage of supported Ocaml versions
+ case "$OCAMLVERSION" in
+-    3.10.1*|3.10.2*|3.1*) ;;
++    3.10.1*|3.10.2*|3.1*|4.*) ;;
+     *)
+       if  test "$REQUIRED_OCAML" != "SVN" ; then
+         echo "********  Version $REQUIRED_OCAML of Objective-Caml is required  *********" 1>&2;
+--- mldonkey-3.1.2.orig/Makefile	2012-05-16 11:56:34.000000000 +0200
++++ mldonkey-3.1.2/Makefile	2012-05-25 19:24:15.000000000 +0200
+@@ -5447,7 +5449,7 @@
+ 	$(OCAMLC) $(DEVFLAGS) $(INCLUDES) -c $<
+ 
+ .mlcpp.ml:
+-	@$(CPP) -x c -P $< $(FIX_BROKEN_CPP) -o $@
++	@$(CPP) -x c -P $< $(FIX_BROKEN_CPP) > $@
+ 
+ %.ml: %.mlp $(BITSTRING)/pa_bitstring.cmo
+ 	$(CAMLP4OF) build/bitstring.cma $(BITSTRING)/bitstring_persistent.cmo $(BITSTRING)/pa_bitstring.cmo -impl $< -o $@
diff --git a/testsuite/external/oasis-common.patch b/testsuite/external/oasis-common.patch
new file mode 100644
index 00000000..c13cd290
--- /dev/null
+++ b/testsuite/external/oasis-common.patch
@@ -0,0 +1,55 @@
+--- setup.ml	2011-03-22 17:00:48.000000000 +0100
++++ setup.ml	2011-12-22 21:41:25.000000000 +0100
+@@ -2662,10 +2662,14 @@
+         (ocamlc_config_map ())
+         0
+     in
+-    let nm_config =
++    let chop_version_suffix s =
++      try String.sub s 0 (String.index s '+')
++      with _ -> s
++    in
++    let nm_config, value_config =
+       match nm with 
+-        | "ocaml_version" -> "version"
+-        | _ -> nm
++        | "ocaml_version" -> "version", chop_version_suffix
++        | _ -> nm, (fun x -> x)
+     in
+       var_redefine
+         nm 
+@@ -2677,7 +2681,7 @@
+               let value = 
+                 SMap.find nm_config map
+               in
+-                value
++                value_config value
+             with Not_found ->
+               failwithf2
+                 (f_ "Cannot find field '%s' in '%s -config' output")
+@@ -3057,7 +3061,7 @@
+             begin
+               let acc = 
+                 try 
+-                  Scanf.bscanf scbuf "%S %S@\n" 
++                  Scanf.bscanf scbuf "%S %S\n" 
+                     (fun e d ->  
+                        let t = 
+                          e, d
+--- setup.ml.orig	2012-03-17 11:50:20.000000000 +0100
++++ setup.ml	2012-07-31 17:45:43.000000000 +0200
+@@ -2284,7 +2284,13 @@
+     let cmdline =
+       String.concat " " (cmd :: args)
+     in
+-      info (f_ "Running command '%s'") cmdline;
++    let printable_cmdline =
++      match List.rev args with
++      | _ :: (">" | "2>") :: rest ->
++         String.concat " " (cmd :: List.rev ("[file]" :: ">" :: rest))
++      | _ -> cmdline
++    in
++      info (f_ "Running command '%s'") printable_cmdline;
+       match f_exit_code, Sys.command cmdline with
+         | None, 0 -> ()
+         | None, i ->
diff --git a/testsuite/external/obrowser-1.1.1.patch b/testsuite/external/obrowser-1.1.1.patch
new file mode 100644
index 00000000..e135f1d3
--- /dev/null
+++ b/testsuite/external/obrowser-1.1.1.patch
@@ -0,0 +1,1161 @@
+--- obrowser-1.1.1/Makefile.orig	2011-07-05 16:15:30.000000000 +0200
++++ obrowser-1.1.1/Makefile	2011-07-05 16:16:42.000000000 +0200
+@@ -16,9 +16,9 @@
+ EXAMPLES = $(patsubst examples/%,%, $(wildcard examples/*))
+ EXAMPLES_TARGETS = $(patsubst examples/%,%.example, $(wildcard examples/*))
+ OCAMLFIND = ocamlfind
+-.PHONY: tuto dist plugin lwt
++.PHONY: tuto dist plugin lwt AXO
+ 
+-all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt
++all: .check_version rt/caml/stdlib.cma vm.js tuto AXO $(EXAMPLES_TARGETS) examples.html lwt
+ 
+ .check_version:
+ 	@[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \
+--- obrowser-1.1.1.orig/Makefile	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/Makefile	2012-03-12 16:55:44.000000000 +0100
+@@ -21,10 +21,11 @@
+ all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt
+ 
+ .check_version:
+-	@[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \
+-	  [ "$(shell ocamlc -vnum)" = "3.12.1" ] || \
+-	  ( echo "You need ocaml version 3.12.0 or 3.12.1"; \
+-            exit 1 )
++	@case `ocaml -vnum` in \
++	  3.1[2-9].*);; \
++	  4.*);; \
++	  *) echo "You need ocaml version 3.12.0 or later"; exit 1;; \
++	 esac
+ 	touch $@
+ 
+ %.example: 
+--- obrowser-1.1.1.orig/rt/caml/pervasives.mli	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.mli	2012-01-12 01:07:49.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -52,24 +52,24 @@
+    Equality between cyclic data structures may not terminate. *)
+ 
+ external ( <> ) : 'a -> 'a -> bool = "%notequal"
+-(** Negation of {!Pervasives.(=)}. *)
++(** Negation of {!Pervasives.( = )}. *)
+ 
+ external ( < ) : 'a -> 'a -> bool = "%lessthan"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+ 
+ external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+ 
+ external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+-(** See {!Pervasives.(>=)}. *)
++(** See {!Pervasives.( >= )}. *)
+ 
+ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+ (** Structural ordering functions. These functions coincide with
+    the usual orderings over integers, characters, strings
+    and floating-point numbers, and extend them to a
+    total ordering over all types.
+-   The ordering is compatible with [(=)]. As in the case
+-   of [(=)], mutable structures are compared by contents.
++   The ordering is compatible with [( = )]. As in the case
++   of [( = )], mutable structures are compared by contents.
+    Comparison between functional values raises [Invalid_argument].
+    Comparison between cyclic structures may not terminate. *)
+ 
+@@ -108,12 +108,12 @@
+    mutable fields and objects with mutable instance variables,
+    [e1 == e2] is true if and only if physical modification of [e1]
+    also affects [e2].
+-   On non-mutable types, the behavior of [(==)] is
++   On non-mutable types, the behavior of [( == )] is
+    implementation-dependent; however, it is guaranteed that
+    [e1 == e2] implies [compare e1 e2 = 0]. *)
+ 
+ external ( != ) : 'a -> 'a -> bool = "%noteq"
+-(** Negation of {!Pervasives.(==)}. *)
++(** Negation of {!Pervasives.( == )}. *)
+ 
+ 
+ (** {6 Boolean operations} *)
+@@ -229,7 +229,7 @@
+ 
+ (** {6 Floating-point arithmetic}
+ 
+-   Caml's floating-point numbers follow the
++   OCaml's floating-point numbers follow the
+    IEEE 754 standard, using double precision (64 bits) numbers.
+    Floating-point operations never raise an exception on overflow,
+    underflow, division by zero, etc.  Instead, special IEEE numbers
+@@ -310,10 +310,18 @@
+     Result is in radians and is between [-pi/2] and [pi/2]. *)
+ 
+ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+-(** [atan x y] returns the arc tangent of [y /. x].  The signs of [x]
++(** [atan2 y x] returns the arc tangent of [y /. x].  The signs of [x]
+     and [y] are used to determine the quadrant of the result.
+     Result is in radians and is between [-pi] and [pi]. *)
+ 
++external hypot : float -> float -> float
++               = "caml_hypot_float" "caml_hypot" "float"
++(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
++  of the hypotenuse of a right-angled triangle with sides of length
++  [x] and [y], or, equivalently, the distance of the point [(x,y)]
++  to origin.
++  @since 3.13.0  *)
++
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ (** Hyperbolic cosine.  Argument is in radians. *)
+ 
+@@ -337,6 +345,14 @@
+ external abs_float : float -> float = "%absfloat"
+ (** [abs_float f] returns the absolute value of [f]. *)
+ 
++external copysign : float -> float -> float
++                  = "caml_copysign_float" "caml_copysign" "float"
++(** [copysign x y] returns a float whose absolute value is that of [x]
++  and whose sign is that of [y].  If [x] is [nan], returns [nan].
++  If [y] is [nan], returns either [x] or [-. x], but it is not
++  specified which.
++  @since 3.13.0  *)
++
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ (** [mod_float a b] returns the remainder of [a] with respect to
+    [b].  The returned value is [a -. n *. b], where [n]
+@@ -505,7 +521,7 @@
+ (** The standard output for the process. *)
+ 
+ val stderr : out_channel
+-(** The standard error ouput for the process. *)
++(** The standard error output for the process. *)
+ 
+ 
+ (** {7 Output functions on standard output} *)
+@@ -642,7 +658,7 @@
+    The given integer is taken modulo 2{^32}.
+    The only reliable way to read it back is through the
+    {!Pervasives.input_binary_int} function. The format is compatible across
+-   all machines for a given version of Objective Caml. *)
++   all machines for a given version of OCaml. *)
+ 
+ val output_value : out_channel -> 'a -> unit
+ (** Write the representation of a structured value of any type
+@@ -855,12 +871,16 @@
+ (** Format strings have a general and highly polymorphic type
+     [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
+     The two simplified types, [format] and [format4] below are
+-    included for backward compatibility with earlier releases of Objective
+-    Caml.
++    included for backward compatibility with earlier releases of OCaml.
+     ['a] is the type of the parameters of the format,
+-    ['c] is the result type for the "printf"-style function,
+-    and ['b] is the type of the first argument given to
+-    [%a] and [%t] printing functions. *)
++    ['b] is the type of the first argument given to
++         [%a] and [%t] printing functions,
++    ['c] is the type of the argument transmitted to the first argument of
++         "kprintf"-style functions,
++    ['d] is the result type for the "scanf"-style functions,
++    ['e] is the type of the receiver function for the "scanf"-style functions,
++    ['f] is the result type for the "printf"-style function.
++ *)
+ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+ 
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+@@ -888,7 +908,7 @@
+ (** Terminate the process, returning the given status code
+    to the operating system: usually 0 to indicate no errors,
+    and a small positive integer to indicate failure.
+-   All open output channels are flushed with flush_all.
++   All open output channels are flushed with [flush_all].
+    An implicit [exit 0] is performed each time a program
+    terminates normally.  An implicit [exit 2] is performed if the program
+    terminates early because of an uncaught exception. *)
+--- obrowser-1.1.1.orig/rt/caml/pervasives.ml	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.ml	2012-01-12 17:04:04.000000000 +0100
+@@ -91,6 +91,8 @@
+ external asin : float -> float = "caml_asin_float" "asin" "float"
+ external atan : float -> float = "caml_atan_float" "atan" "float"
+ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
++external hypot : float -> float -> float
++               = "caml_hypot_float" "caml_hypot" "float"
+ external cos : float -> float = "caml_cos_float" "cos" "float"
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ external log : float -> float = "caml_log_float" "log" "float"
+@@ -104,6 +106,8 @@
+ external ceil : float -> float = "caml_ceil_float" "ceil" "float"
+ external floor : float -> float = "caml_floor_float" "floor" "float"
+ external abs_float : float -> float = "%absfloat"
++external copysign : float -> float -> float
++                  = "caml_copysign_float" "caml_copysign" "float"
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ external frexp : float -> float * int = "caml_frexp_float"
+ external ldexp : float -> int -> float = "caml_ldexp_float"
+--- obrowser-1.1.1.orig/rt/caml/list.ml	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/list.ml	2012-01-12 17:30:31.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -56,6 +56,12 @@
+     [] -> []
+   | a::l -> let r = f a in r :: map f l
+ 
++let rec mapi i f = function
++    [] -> []
++  | a::l -> let r = f i a in r :: mapi (i + 1) f l
++
++let mapi f l = mapi 0 f l
++
+ let rev_map f l =
+   let rec rmap_f accu = function
+     | [] -> accu
+@@ -68,6 +74,12 @@
+     [] -> ()
+   | a::l -> f a; iter f l
+ 
++let rec iteri i f = function
++    [] -> ()
++  | a::l -> f i a; iteri (i + 1) f l
++
++let iteri f l = iteri 0 f l
++
+ let rec fold_left f accu l =
+   match l with
+     [] -> accu
+--- obrowser-1.1.1.orig/rt/caml/list.mli	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/list.mli	2012-01-12 17:30:31.000000000 +0100
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -75,11 +75,25 @@
+    [a1; ...; an]. It is equivalent to
+    [begin f a1; f a2; ...; f an; () end]. *)
+ 
++val iteri : (int -> 'a -> unit) -> 'a list -> unit
++(** Same as {!List.iter}, but the function is applied to the index of
++   the element as first argument (counting from 0), and the element
++   itself as second argument.
++   @since 3.13.0
++*)
++
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+    and builds the list [[f a1; ...; f an]]
+    with the results returned by [f].  Not tail-recursive. *)
+ 
++val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
++(** Same as {!List.map}, but the function is applied to the index of
++   the element as first argument (counting from 0), and the element
++   itself as second argument.  Not tail-recursive.
++   @since 3.13.0
++*)
++
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ (** [List.rev_map f l] gives the same result as
+    {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
+--- obrowser-1.1.1-old/rt/caml/pervasives.mli	2013-06-20 13:50:19.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.mli	2013-06-20 13:50:59.000000000 +0200
+@@ -11,8 +11,6 @@
+ (*                                                                     *)
+ (***********************************************************************)
+ 
+-(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *)
+-
+ (** The initially opened module.
+ 
+    This module provides the basic operations over the built-in types
+@@ -122,7 +120,7 @@
+ (** The boolean negation. *)
+ 
+ external ( && ) : bool -> bool -> bool = "%sequand"
+-(** The boolean ``and''. Evaluation is sequential, left-to-right:
++(** The boolean 'and'. Evaluation is sequential, left-to-right:
+    in [e1 && e2], [e1] is evaluated first, and if it returns [false],
+    [e2] is not evaluated at all. *)
+ 
+@@ -130,7 +128,7 @@
+ (** @deprecated {!Pervasives.( && )} should be used instead. *)
+ 
+ external ( || ) : bool -> bool -> bool = "%sequor"
+-(** The boolean ``or''. Evaluation is sequential, left-to-right:
++(** The boolean 'or'. Evaluation is sequential, left-to-right:
+    in [e1 || e2], [e1] is evaluated first, and if it returns [true],
+    [e2] is not evaluated at all. *)
+ 
+@@ -138,6 +136,20 @@
+ (** @deprecated {!Pervasives.( || )} should be used instead.*)
+ 
+ 
++(** {6 Composition operators} *)
++
++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
++(** Reverse-application operator: [x |> f |> g] is exactly equivalent
++ to [g (f (x))].
++   @since 4.01
++*)
++
++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
++(** Application operator: [g @@ f @@ x] is exactly equivalent to
++ [g (f (x))].
++   @since 4.01
++*)
++
+ (** {6 Integer arithmetic} *)
+ 
+ (** Integers are 31 bits wide (or 63 bits on 64-bit processors).
+@@ -234,7 +246,7 @@
+    Floating-point operations never raise an exception on overflow,
+    underflow, division by zero, etc.  Instead, special IEEE numbers
+    are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+-   [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
++   [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
+    for [0.0 /. 0.0].  These special numbers then propagate through
+    floating-point computations as expected: for instance,
+    [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
+@@ -320,7 +332,7 @@
+   of the hypotenuse of a right-angled triangle with sides of length
+   [x] and [y], or, equivalently, the distance of the point [(x,y)]
+   to origin.
+-  @since 3.13.0  *)
++  @since 4.00.0  *)
+ 
+ external cosh : float -> float = "caml_cosh_float" "cosh" "float"
+ (** Hyperbolic cosine.  Argument is in radians. *)
+@@ -351,7 +363,7 @@
+   and whose sign is that of [y].  If [x] is [nan], returns [nan].
+   If [y] is [nan], returns either [x] or [-. x], but it is not
+   specified which.
+-  @since 3.13.0  *)
++  @since 4.00.0  *)
+ 
+ external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
+ (** [mod_float a b] returns the remainder of [a] with respect to
+@@ -395,7 +407,7 @@
+ val nan : float
+ (** A special floating-point value denoting the result of an
+    undefined operation such as [0.0 /. 0.0].  Stands for
+-   ``not a number''.  Any floating-point operation with [nan] as
++   'not a number'.  Any floating-point operation with [nan] as
+    argument returns [nan] as result.  As for floating-point comparisons,
+    [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
+    if one or both of their arguments is [nan]. *)
+@@ -461,7 +473,9 @@
+ (** {6 String conversion functions} *)
+ 
+ val string_of_bool : bool -> string
+-(** Return the string representation of a boolean. *)
++(** Return the string representation of a boolean. As the returned values
++   may be shared, the user should not modify them directly.
++*)
+ 
+ val bool_of_string : string -> bool
+ (** Convert the given string to a boolean.
+@@ -506,7 +520,9 @@
+ (** List concatenation. *)
+ 
+ 
+-(** {6 Input/output} *)
++(** {6 Input/output}
++    Note: all input/output functions can raise [Sys_error] when the system
++    calls they invoke fail. *)
+ 
+ type in_channel
+ (** The type of input channel. *)
+@@ -864,23 +880,73 @@
+ 
+ (** {6 Operations on format strings} *)
+ 
+-(** Format strings are used to read and print data using formatted input
+-    functions in module {!Scanf} and formatted output in modules {!Printf} and
+-    {!Format}. *)
++(** Format strings are character strings with special lexical conventions
++  that defines the functionality of formatted input/output functions. Format
++  strings are used to read data with formatted input functions from module
++  {!Scanf} and to print data with formatted output functions from modules
++  {!Printf} and {!Format}.
++
++  Format strings are made of three kinds of entities:
++  - {e conversions specifications}, introduced by the special character ['%']
++    followed by one or more characters specifying what kind of argument to
++    read or print,
++  - {e formatting indications}, introduced by the special character ['@']
++    followed by one or more characters specifying how to read or print the
++    argument,
++  - {e plain characters} that are regular characters with usual lexical
++    conventions. Plain characters specify string literals to be read in the
++    input or printed in the output.
++
++  There is an additional lexical rule to escape the special characters ['%']
++  and ['@'] in format strings: if a special character follows a ['%']
++  character, it is treated as a plain character. In other words, ["%%"] is
++  considered as a plain ['%'] and ["%@"] as a plain ['@'].
++
++  For more information about conversion specifications and formatting
++  indications available, read the documentation of modules {!Scanf},
++  {!Printf} and {!Format}.
++*)
+ 
+ (** Format strings have a general and highly polymorphic type
+     [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
+     The two simplified types, [format] and [format4] below are
+-    included for backward compatibility with earlier releases of OCaml.
+-    ['a] is the type of the parameters of the format,
+-    ['b] is the type of the first argument given to
+-         [%a] and [%t] printing functions,
+-    ['c] is the type of the argument transmitted to the first argument of
+-         "kprintf"-style functions,
+-    ['d] is the result type for the "scanf"-style functions,
+-    ['e] is the type of the receiver function for the "scanf"-style functions,
+-    ['f] is the result type for the "printf"-style function.
+- *)
++    included for backward compatibility with earlier releases of
++    OCaml.
++
++    The meaning of format string type parameters is as follows:
++
++    - ['a] is the type of the parameters of the format for formatted output
++      functions ([printf]-style functions);
++      ['a] is the type of the values read by the format for formatted input
++      functions ([scanf]-style functions).
++
++    - ['b] is the type of input source for formatted input functions and the
++      type of output target for formatted output functions.
++      For [printf]-style functions from module [Printf], ['b] is typically
++      [out_channel];
++      for [printf]-style functions from module [Format], ['b] is typically
++      [Format.formatter];
++      for [scanf]-style functions from module [Scanf], ['b] is typically
++      [Scanf.Scanning.in_channel].
++
++      Type argument ['b] is also the type of the first argument given to
++      user's defined printing functions for [%a] and [%t] conversions,
++      and user's defined reading functions for [%r] conversion.
++
++    - ['c] is the type of the result of the [%a] and [%t] printing
++      functions, and also the type of the argument transmitted to the
++      first argument of [kprintf]-style functions or to the
++      [kscanf]-style functions.
++
++    - ['d] is the type of parameters for the [scanf]-style functions.
++
++    - ['e] is the type of the receiver function for the [scanf]-style functions.
++
++    - ['f] is the final result type of a formatted input/output function
++      invocation: for the [printf]-style functions, it is typically [unit];
++      for the [scanf]-style functions, it is typically the result type of the
++      receiver function.
++*)
+ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+ 
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+@@ -892,14 +958,22 @@
+   ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+   ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
+ (** [format_of_string s] returns a format string read from the string
+-    literal [s]. *)
++    literal [s].
++    Note: [format_of_string] can not convert a string argument that is not a
++    literal. If you need this functionality, use the more general
++    {!Scanf.format_from_string} function.
++*)
+ 
+ val ( ^^ ) :
+       ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
+       ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+       ('a, 'b, 'c, 'd, 'g, 'h) format6
+-(** [f1 ^^ f2] catenates formats [f1] and [f2].  The result is a format
+-  that accepts arguments from [f1], then arguments from [f2]. *)
++(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
++  format string that behaves as the concatenation of format strings [f1] and
++  [f2]: in case of formatted output, it accepts arguments from [f1], then
++  arguments from [f2]; in case of formatted input, it returns results from
++  [f1], then results from [f2].
++*)
+ 
+ 
+ (** {6 Program termination} *)
+@@ -918,13 +992,12 @@
+    termination time. The functions registered with [at_exit]
+    will be called when the program executes {!Pervasives.exit},
+    or terminates, either normally or because of an uncaught exception.
+-   The functions are called in ``last in, first out'' order:
++   The functions are called in 'last in, first out' order:
+    the function most recently added with [at_exit] is called first. *)
+ 
+ (**/**)
+ 
+-
+-(** {6 For system use only, not for the casual user} *)
++(* The following is for system use only. Do not call directly. *)
+ 
+ val valid_float_lexem : string -> string
+ 
+--- obrowser-1.1.1-old/rt/caml/pervasives.ml	2013-06-20 13:50:19.000000000 +0200
++++ obrowser-1.1.1/rt/caml/pervasives.ml	2013-06-20 13:51:53.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -11,8 +11,6 @@
+ (*                                                                     *)
+ (***********************************************************************)
+ 
+-(* $Id: pervasives.ml 9412 2009-11-09 11:42:39Z weis $ *)
+-
+ (* type 'a option = None | Some of 'a *)
+ 
+ (* Exceptions *)
+@@ -24,66 +22,70 @@
+ 
+ exception Exit
+ 
++(* Composition operators *)
++
++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
++
+ (* Comparisons *)
+ 
+-external (=) : 'a -> 'a -> bool = "%equal"
+-external (<>) : 'a -> 'a -> bool = "%notequal"
+-external (<) : 'a -> 'a -> bool = "%lessthan"
+-external (>) : 'a -> 'a -> bool = "%greaterthan"
+-external (<=) : 'a -> 'a -> bool = "%lessequal"
+-external (>=) : 'a -> 'a -> bool = "%greaterequal"
+-external compare: 'a -> 'a -> int = "%compare"
++external ( = ) : 'a -> 'a -> bool = "%equal"
++external ( <> ) : 'a -> 'a -> bool = "%notequal"
++external ( < ) : 'a -> 'a -> bool = "%lessthan"
++external ( > ) : 'a -> 'a -> bool = "%greaterthan"
++external ( <= ) : 'a -> 'a -> bool = "%lessequal"
++external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
++external compare : 'a -> 'a -> int = "%compare"
+ 
+ let min x y = if x <= y then x else y
+ let max x y = if x >= y then x else y
+ 
+-external (==) : 'a -> 'a -> bool = "%eq"
+-external (!=) : 'a -> 'a -> bool = "%noteq"
++external ( == ) : 'a -> 'a -> bool = "%eq"
++external ( != ) : 'a -> 'a -> bool = "%noteq"
+ 
+ (* Boolean operations *)
+ 
+ external not : bool -> bool = "%boolnot"
+-external (&) : bool -> bool -> bool = "%sequand"
+-external (&&) : bool -> bool -> bool = "%sequand"
+-external (or) : bool -> bool -> bool = "%sequor"
+-external (||) : bool -> bool -> bool = "%sequor"
++external ( & ) : bool -> bool -> bool = "%sequand"
++external ( && ) : bool -> bool -> bool = "%sequand"
++external ( or ) : bool -> bool -> bool = "%sequor"
++external ( || ) : bool -> bool -> bool = "%sequor"
+ 
+ (* Integer operations *)
+ 
+-external (~-) : int -> int = "%negint"
+-external (~+) : int -> int = "%identity"
++external ( ~- ) : int -> int = "%negint"
++external ( ~+ ) : int -> int = "%identity"
+ external succ : int -> int = "%succint"
+ external pred : int -> int = "%predint"
+-external (+) : int -> int -> int = "%addint"
+-external (-) : int -> int -> int = "%subint"
+-external ( * ) : int -> int -> int = "%mulint"
+-external (/) : int -> int -> int = "%divint"
+-external (mod) : int -> int -> int = "%modint"
++external ( + ) : int -> int -> int = "%addint"
++external ( - ) : int -> int -> int = "%subint"
++external ( *  ) : int -> int -> int = "%mulint"
++external ( / ) : int -> int -> int = "%divint"
++external ( mod ) : int -> int -> int = "%modint"
+ 
+ let abs x = if x >= 0 then x else -x
+ 
+-external (land) : int -> int -> int = "%andint"
+-external (lor) : int -> int -> int = "%orint"
+-external (lxor) : int -> int -> int = "%xorint"
++external ( land ) : int -> int -> int = "%andint"
++external ( lor ) : int -> int -> int = "%orint"
++external ( lxor ) : int -> int -> int = "%xorint"
+ 
+ let lnot x = x lxor (-1)
+ 
+-external (lsl) : int -> int -> int = "%lslint"
+-external (lsr) : int -> int -> int = "%lsrint"
+-external (asr) : int -> int -> int = "%asrint"
++external ( lsl ) : int -> int -> int = "%lslint"
++external ( lsr ) : int -> int -> int = "%lsrint"
++external ( asr ) : int -> int -> int = "%asrint"
+ 
+-let min_int = 1 lsl (if 1 lsl 32 = 1 then 31 else 63) (* obrowser mod: no tag bit*)
++let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
+ let max_int = min_int - 1
+ 
+-
+ (* Floating-point operations *)
+ 
+-external (~-.) : float -> float = "%negfloat"
+-external (~+.) : float -> float = "%identity"
+-external (+.) : float -> float -> float = "%addfloat"
+-external (-.) : float -> float -> float = "%subfloat"
++external ( ~-. ) : float -> float = "%negfloat"
++external ( ~+. ) : float -> float = "%identity"
++external ( +. ) : float -> float -> float = "%addfloat"
++external ( -. ) : float -> float -> float = "%subfloat"
+ external ( *. ) : float -> float -> float = "%mulfloat"
+-external (/.) : float -> float -> float = "%divfloat"
++external ( /. ) : float -> float -> float = "%divfloat"
+ external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
+ external exp : float -> float = "caml_exp_float" "exp" "float"
+ external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float"
+@@ -136,16 +138,16 @@
+   | FP_zero
+   | FP_infinite
+   | FP_nan
+-external classify_float: float -> fpclass = "caml_classify_float"
++external classify_float : float -> fpclass = "caml_classify_float"
+ 
+ (* String operations -- more in module String *)
+ 
+ external string_length : string -> int = "%string_length"
+-external string_create: int -> string = "caml_create_string"
++external string_create : int -> string = "caml_create_string"
+ external string_blit : string -> int -> string -> int -> int -> unit
+                      = "caml_blit_string" "noalloc"
+ 
+-let (^) s1 s2 =
++let ( ^ ) s1 s2 =
+   let l1 = string_length s1 and l2 = string_length s2 in
+   let s = string_create (l1 + l2) in
+   string_blit s1 0 s 0 l1;
+@@ -170,8 +172,8 @@
+ 
+ (* String conversion functions *)
+ 
+-external format_int: string -> int -> string = "caml_format_int"
+-external format_float: string -> float -> string = "caml_format_float"
++external format_int : string -> int -> string = "caml_format_int"
++external format_float : string -> float -> string = "caml_format_float"
+ 
+ let string_of_bool b =
+   if b then "true" else "false"
+@@ -187,7 +189,6 @@
+ 
+ module String = struct
+   external get : string -> int -> char = "%string_safe_get"
+-  external set : string -> int -> char -> unit = "%string_safe_set"
+ end
+ 
+ let valid_float_lexem s =
+@@ -195,7 +196,7 @@
+   let rec loop i =
+     if i >= l then s ^ "." else
+     match s.[i] with
+-    | '0' .. '9' | '-' -> loop (i+1)
++    | '0' .. '9' | '-' -> loop (i + 1)
+     | _ -> s
+   in
+   loop 0
+@@ -207,7 +208,7 @@
+ 
+ (* List operations -- more in module List *)
+ 
+-let rec (@) l1 l2 =
++let rec ( @ ) l1 l2 =
+   match l1 with
+     [] -> l2
+   | hd :: tl -> hd :: (tl @ l2)
+@@ -217,12 +218,13 @@
+ type in_channel
+ type out_channel
+ 
+-let open_descriptor_out _ = failwith "not implemented in obrowser"
+-let open_descriptor_in _ = failwith "not implemented in obrowser"
+-
+-let stdin = Obj.magic 0
+-let stdout = Obj.magic 0
+-let stderr = Obj.magic 0
++external open_descriptor_out : int -> out_channel
++                             = "caml_ml_open_descriptor_out"
++external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
++
++let stdin = open_descriptor_in 0
++let stdout = open_descriptor_out 1
++let stderr = open_descriptor_out 2
+ 
+ (* General output functions *)
+ 
+@@ -231,103 +233,184 @@
+   | Open_creat | Open_trunc | Open_excl
+   | Open_binary | Open_text | Open_nonblock
+ 
+-let open_desc _ _ _ = failwith "not implemented in obrowser"
+-let open_out_gen mode perm name = failwith "not implemented in obrowser"
+-let open_out name = failwith "not implemented in obrowser"
+-let open_out_bin name = failwith "not implemented in obrowser"
+-let flush _ =  failwith "not implemented in obrowser"
+-let out_channels_list _ = failwith "not implemented in obrowser"
+-let flush_all () = failwith "not implemented in obrowser"
+-let unsafe_output _ _ _ _ = failwith "not implemented in obrowser"
+-let output_char _ _ = failwith "not implemented in obrowser"
+-let output_string oc s = failwith "not implemented in obrowser"
+-let output oc s ofs len = failwith "not implemented in obrowser"
+-let output_byte _ _ = failwith "not implemented in obrowser"
+-let  output_binary_int _ _ = failwith "not implemented in obrowser"
+-let marshal_to_channel _ _ _ = failwith "not implemented in obrowser"
+-let output_value _ _ = failwith "not implemented in obrowser"
+-let seek_out _ _ = failwith "not implemented in obrowser"
+-let pos_out _ = failwith "not implemented in obrowser"
+-let out_channel_length _ = failwith "not implemented in obrowser"
+-let close_out_channel _ = failwith "not implemented in obrowser"
+-let close_out _ = failwith "not implemented in obrowser"
+-let close_out_noerr _ = failwith "not implemented in obrowser"
+-let set_binary_mode_out _ _  = failwith "not implemented in obrowser"
++external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
++
++let open_out_gen mode perm name =
++  open_descriptor_out(open_desc name mode perm)
++
++let open_out name =
++  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
++
++let open_out_bin name =
++  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
++
++external flush : out_channel -> unit = "caml_ml_flush"
++
++external out_channels_list : unit -> out_channel list
++                           = "caml_ml_out_channels_list"
++
++let flush_all () =
++  let rec iter = function
++      [] -> ()
++    | a :: l -> (try flush a with _ -> ()); iter l
++  in iter (out_channels_list ())
++
++external unsafe_output : out_channel -> string -> int -> int -> unit
++                       = "caml_ml_output"
++
++external output_char : out_channel -> char -> unit = "caml_ml_output_char"
++
++let output_string oc s =
++  unsafe_output oc s 0 (string_length s)
++
++let output oc s ofs len =
++  if ofs < 0 || len < 0 || ofs > string_length s - len
++  then invalid_arg "output"
++  else unsafe_output oc s ofs len
++
++external output_byte : out_channel -> int -> unit = "caml_ml_output_char"
++external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int"
++
++external marshal_to_channel : out_channel -> 'a -> unit list -> unit
++     = "caml_output_value"
++let output_value chan v = marshal_to_channel chan v []
++
++external seek_out : out_channel -> int -> unit = "caml_ml_seek_out"
++external pos_out : out_channel -> int = "caml_ml_pos_out"
++external out_channel_length : out_channel -> int = "caml_ml_channel_size"
++external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
++let close_out oc = flush oc; close_out_channel oc
++let close_out_noerr oc =
++  (try flush oc with _ -> ());
++  (try close_out_channel oc with _ -> ())
++external set_binary_mode_out : out_channel -> bool -> unit
++                             = "caml_ml_set_binary_mode"
+ 
+ (* General input functions *)
+ 
+-let open_in_gen _ _ _ =  failwith "not implemented in obrowser"
+-let open_in _ =  failwith "not implemented in obrowser"
+-let open_in_bin _ =  failwith "not implemented in obrowser"
+-let input_char _ =  failwith "not implemented in obrowser"
+-let unsafe_input _ _ _ _ = failwith "not implemented in obrowser"
+-let input _ _ _ _ = failwith "not implemented in obrowser"
+-let rec unsafe_really_input _ _ _ _ = failwith "not implemented in obrowser"
+-let really_input _ _ _ _ = failwith "not implemented in obrowser"
+-let input_scan_line _ = failwith "not implemented in obrowser"
+-let input_line _ = failwith "not implemented in obrowser"
+-
+-let input_byte _ = failwith "not implemented in obrowser"
+-let input_binary_int _ = failwith "not implemented in obrowser"
+-let input_value _ = failwith "not implemented in obrowser"
+-let seek_in _ _ = failwith "not implemented in obrowser"
+-let pos_in _ = failwith "not implemented in obrowser"
+-let in_channel_length _ = failwith "not implemented in obrowser"
+-let close_in _ = failwith "not implemented in obrowser"
+-let close_in_noerr _ = failwith "not implemented in obrowser"
+-let set_binary_mode_in _ _ = failwith "not implemented in obrowser"
++let open_in_gen mode perm name =
++  open_descriptor_in(open_desc name mode perm)
+ 
+-(* Output functions on standard output *)
++let open_in name =
++  open_in_gen [Open_rdonly; Open_text] 0 name
++
++let open_in_bin name =
++  open_in_gen [Open_rdonly; Open_binary] 0 name
++
++external input_char : in_channel -> char = "caml_ml_input_char"
++
++external unsafe_input : in_channel -> string -> int -> int -> int
++                      = "caml_ml_input"
++
++let input ic s ofs len =
++  if ofs < 0 || len < 0 || ofs > string_length s - len
++  then invalid_arg "input"
++  else unsafe_input ic s ofs len
++
++let rec unsafe_really_input ic s ofs len =
++  if len <= 0 then () else begin
++    let r = unsafe_input ic s ofs len in
++    if r = 0
++    then raise End_of_file
++    else unsafe_really_input ic s (ofs + r) (len - r)
++  end
+ 
+-external basic_io_write : string -> unit = "caml_basic_io_write"
++let really_input ic s ofs len =
++  if ofs < 0 || len < 0 || ofs > string_length s - len
++  then invalid_arg "really_input"
++  else unsafe_really_input ic s ofs len
++
++external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"
++
++let input_line chan =
++  let rec build_result buf pos = function
++    [] -> buf
++  | hd :: tl ->
++      let len = string_length hd in
++      string_blit hd 0 buf (pos - len) len;
++      build_result buf (pos - len) tl in
++  let rec scan accu len =
++    let n = input_scan_line chan in
++    if n = 0 then begin                   (* n = 0: we are at EOF *)
++      match accu with
++        [] -> raise End_of_file
++      | _  -> build_result (string_create len) len accu
++    end else if n > 0 then begin          (* n > 0: newline found in buffer *)
++      let res = string_create (n - 1) in
++      ignore (unsafe_input chan res 0 (n - 1));
++      ignore (input_char chan);           (* skip the newline *)
++      match accu with
++        [] -> res
++      |  _ -> let len = len + n - 1 in
++              build_result (string_create len) len (res :: accu)
++    end else begin                        (* n < 0: newline not found *)
++      let beg = string_create (-n) in
++      ignore(unsafe_input chan beg 0 (-n));
++      scan (beg :: accu) (len - n)
++    end
++  in scan [] 0
++
++external input_byte : in_channel -> int = "caml_ml_input_char"
++external input_binary_int : in_channel -> int = "caml_ml_input_int"
++external input_value : in_channel -> 'a = "caml_input_value"
++external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
++external pos_in : in_channel -> int = "caml_ml_pos_in"
++external in_channel_length : in_channel -> int = "caml_ml_channel_size"
++external close_in : in_channel -> unit = "caml_ml_close_channel"
++let close_in_noerr ic = (try close_in ic with _ -> ());;
++external set_binary_mode_in : in_channel -> bool -> unit
++                            = "caml_ml_set_binary_mode"
+ 
+-let print_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s)
+-let print_string s = basic_io_write s
+-let print_int i = basic_io_write (string_of_int i)
+-let print_float f = basic_io_write (string_of_float f)
++(* Output functions on standard output *)
++
++let print_char c = output_char stdout c
++let print_string s = output_string stdout s
++let print_int i = output_string stdout (string_of_int i)
++let print_float f = output_string stdout (string_of_float f)
+ let print_endline s =
+-  print_string s; print_char '\n'
+-let print_newline () = print_char '\n'
++  output_string stdout s; output_char stdout '\n'; flush stdout
++let print_newline () = output_char stdout '\n'; flush stdout
+ 
+ (* Output functions on standard error *)
+ 
+-let prerr_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s)
+-let prerr_string s = basic_io_write s
+-let prerr_int i = basic_io_write (string_of_int i)
+-let prerr_float f = basic_io_write (string_of_float f)
++let prerr_char c = output_char stderr c
++let prerr_string s = output_string stderr s
++let prerr_int i = output_string stderr (string_of_int i)
++let prerr_float f = output_string stderr (string_of_float f)
+ let prerr_endline s =
+-  prerr_string s; prerr_char '\n'
+-let prerr_newline () = prerr_char '\n'
++  output_string stderr s; output_char stderr '\n'; flush stderr
++let prerr_newline () = output_char stderr '\n'; flush stderr
+ 
+ (* Input functions on standard input *)
+ 
+-let read_line () = failwith "not implemented in obrowser"
+-let read_int () = failwith "not implemented in obrowser"
+-let read_float () = failwith "not implemented in obrowser"
++let read_line () = flush stdout; input_line stdin
++let read_int () = int_of_string(read_line())
++let read_float () = float_of_string(read_line())
+ 
+ (* Operations on large files *)
+ 
+ module LargeFile =
+   struct
+-    let seek_out _ _ = failwith "not implemented in obrowser"
+-    let pos_out _ = failwith "not implemented in obrowser"
+-    let out_channel_length _ = failwith "not implemented in obrowser"
+-    let seek_in _ _ = failwith "not implemented in obrowser"
+-    let pos_in _ = failwith "not implemented in obrowser"
+-    let in_channel_length _ = failwith "not implemented in obrowser"
++    external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
++    external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
++    external out_channel_length : out_channel -> int64
++                                = "caml_ml_channel_size_64"
++    external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
++    external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
++    external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
+   end
+ 
+ (* References *)
+ 
+-type 'a ref = { mutable contents: 'a }
+-external ref: 'a -> 'a ref = "%makemutable"
+-external (!): 'a ref -> 'a = "%field0"
+-external (:=): 'a ref -> 'a -> unit = "%setfield0"
+-external incr: int ref -> unit = "%incr"
+-external decr: int ref -> unit = "%decr"
++type 'a ref = { mutable contents : 'a }
++external ref : 'a -> 'a ref = "%makemutable"
++external ( ! ) : 'a ref -> 'a = "%field0"
++external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
++external incr : int ref -> unit = "%incr"
++external decr : int ref -> unit = "%decr"
+ 
+ (* Formats *)
+-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 
++type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
+ 
+ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
+ 
+@@ -345,7 +428,8 @@
+       ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
+       ('a, 'b, 'c, 'd, 'g, 'h) format6) =
+   fun fmt1 fmt2 ->
+-    string_to_format (format_to_string fmt1 ^ format_to_string fmt2);;
++    string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2)
++;;
+ 
+ let string_of_format fmt =
+   let s = format_to_string fmt in
+@@ -358,7 +442,7 @@
+ 
+ external sys_exit : int -> 'a = "caml_sys_exit"
+ 
+-let exit_function = ref (fun () -> ())
++let exit_function = ref flush_all
+ 
+ let at_exit f =
+   let g = !exit_function in
+--- obrowser-1.1.1.orig/rt/caml/printexc.ml	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/printexc.ml	2013-08-13 15:54:35.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -11,8 +11,6 @@
+ (*                                                                     *)
+ (***********************************************************************)
+ 
+-(* $Id: printexc.ml 10272 2010-04-19 12:25:46Z frisch $ *)
+-
+ open Printf;;
+ 
+ let printers = ref []
+@@ -56,9 +54,12 @@
+             sprintf locfmt file line char (char+5) "Pattern matching failed"
+         | Assert_failure(file, line, char) ->
+             sprintf locfmt file line char (char+6) "Assertion failed"
++        | Undefined_recursive_module(file, line, char) ->
++            sprintf locfmt file line char (char+6) "Undefined recursive module"
+         | _ ->
+             let x = Obj.repr x in
+-            let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
++            let constructor =
++              (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
+             constructor ^ (fields x) in
+   conv !printers
+ 
+@@ -78,6 +79,11 @@
+     eprintf "Uncaught exception: %s\n" (to_string x);
+     exit 2
+ 
++type raw_backtrace
++
++external get_raw_backtrace:
++  unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
++
+ type loc_info =
+   | Known_location of bool   (* is_raise *)
+                     * string (* filename *)
+@@ -86,8 +92,13 @@
+                     * int    (* end char *)
+   | Unknown_location of bool (*is_raise*)
+ 
+-external get_exception_backtrace:
+-  unit -> loc_info array option = "caml_get_exception_backtrace"
++(* to avoid warning *)
++let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
++
++type backtrace = loc_info array
++
++external convert_raw_backtrace:
++  raw_backtrace -> backtrace option = "caml_convert_raw_backtrace"
+ 
+ let format_loc_info pos li =
+   let is_raise =
+@@ -108,8 +119,8 @@
+       sprintf "%s unknown location"
+               info
+ 
+-let print_backtrace outchan =
+-  match get_exception_backtrace() with
++let print_exception_backtrace outchan backtrace =
++  match backtrace with
+   | None ->
+       fprintf outchan
+         "(Program not linked with -g, cannot print stack backtrace)\n"
+@@ -119,8 +130,15 @@
+           fprintf outchan "%s\n" (format_loc_info i a.(i))
+       done
+ 
+-let get_backtrace () =
+-  match get_exception_backtrace() with
++let print_raw_backtrace outchan raw_backtrace =
++  print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
++
++(* confusingly named: prints the global current backtrace *)
++let print_backtrace outchan =
++  print_raw_backtrace outchan (get_raw_backtrace ())
++
++let backtrace_to_string backtrace =
++  match backtrace with
+   | None ->
+      "(Program not linked with -g, cannot print stack backtrace)\n"
+   | Some a ->
+@@ -131,8 +149,22 @@
+       done;
+       Buffer.contents b
+ 
++let raw_backtrace_to_string raw_backtrace =
++  backtrace_to_string (convert_raw_backtrace raw_backtrace)
++
++(* confusingly named:
++   returns the *string* corresponding to the global current backtrace *)
++let get_backtrace () =
++  (* we could use the caml_get_exception_backtrace primitive here, but
++     we hope to deprecate it so it's better to just compose the
++     raw stuff *)
++  backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
++
+ external record_backtrace: bool -> unit = "caml_record_backtrace"
+ external backtrace_status: unit -> bool = "caml_backtrace_status"
+ 
+ let register_printer fn =
+   printers := fn :: !printers
++
++
++external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
+--- obrowser-1.1.1.orig/rt/caml/printexc.mli	2011-04-20 18:26:44.000000000 +0200
++++ obrowser-1.1.1/rt/caml/printexc.mli	2013-08-13 15:54:40.000000000 +0200
+@@ -1,6 +1,6 @@
+ (***********************************************************************)
+ (*                                                                     *)
+-(*                           Objective Caml                            *)
++(*                                OCaml                                *)
+ (*                                                                     *)
+ (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+ (*                                                                     *)
+@@ -11,9 +11,7 @@
+ (*                                                                     *)
+ (***********************************************************************)
+ 
+-(* $Id: printexc.mli 10457 2010-05-21 18:30:12Z doligez $ *)
+-
+-(** Facilities for printing exceptions. *)
++(** Facilities for printing exceptions and inspecting current call stack. *)
+ 
+ val to_string: exn -> string
+ (** [Printexc.to_string e] returns a string representation of
+@@ -77,5 +75,40 @@
+     in the reverse order of their registrations, until a printer returns
+     a [Some s] value (if no such printer exists, the runtime will use a
+     generic printer).
++
++    When using this mechanism, one should be aware that an exception backtrace
++    is attached to the thread that saw it raised, rather than to the exception
++    itself. Practically, it means that the code related to [fn] should not use
++    the backtrace if it has itself raised an exception before.
+     @since 3.11.2
+ *)
++
++(** {6 Raw backtraces} *)
++
++type raw_backtrace
++
++(** The abstract type [backtrace] stores exception backtraces in
++    a low-level format, instead of directly exposing them as string as
++    the [get_backtrace()] function does.
++
++    This allows to pay the performance overhead of representation
++    conversion and formatting only at printing time, which is useful
++    if you want to record more backtrace than you actually print.
++*)
++
++val get_raw_backtrace: unit -> raw_backtrace
++val print_raw_backtrace: out_channel -> raw_backtrace -> unit
++val raw_backtrace_to_string: raw_backtrace -> string
++
++
++(** {6 Current call stack} *)
++
++val get_callstack: int -> raw_backtrace
++
++(** [Printexc.get_callstack n] returns a description of the top of the
++    call stack on the current program point (for the current thread),
++    with at most [n] entries.  (Note: this function is not related to
++    exceptions at all, despite being part of the [Printexc] module.)
++
++    @since 4.01.0
++*)
diff --git a/testsuite/external/ocaml-bitstring-2.0.3.patch b/testsuite/external/ocaml-bitstring-2.0.3.patch
new file mode 100644
index 00000000..b73bca13
--- /dev/null
+++ b/testsuite/external/ocaml-bitstring-2.0.3.patch
@@ -0,0 +1,11 @@
+--- ocaml-bitstring-2.0.3/Makefile.in.orig	2013-04-04 17:42:45.000000000 +0200
++++ ocaml-bitstring-2.0.3/Makefile.in	2013-04-04 17:43:06.000000000 +0200
+@@ -123,7 +123,7 @@
+ 
+ byteswap.h: byteswap.in.h
+ 	{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+-	  cat $(srcdir)/byteswap.in.h; \
++	  cat byteswap.in.h; \
+ 	} > $@-t
+ 	mv -f $@-t $@
+ 
diff --git a/testsuite/external/ocaml-mysql-1.0.4.patch.disabled b/testsuite/external/ocaml-mysql-1.0.4.patch.disabled
new file mode 100644
index 00000000..82da79df
--- /dev/null
+++ b/testsuite/external/ocaml-mysql-1.0.4.patch.disabled
@@ -0,0 +1,15 @@
+--- ocaml-mysql-1.0.4.orig/mysql_stubs.c	2006-02-24 00:12:36.000000000 +0100
++++ ocaml-mysql-1.0.4/mysql_stubs.c	2012-08-09 20:51:24.000000000 +0200
+@@ -19,9 +19,9 @@
+ 
+ /* MySQL API */
+ 
+-#include 
+-#include 
+-#include 
++#include 
++#include 
++#include 
+ /* type 'a option = None | Some of 'a */
+ 
+ #define NONE            Val_int(0)     
diff --git a/testsuite/external/ocamlnet-3.5.1.patch b/testsuite/external/ocamlnet-3.5.1.patch
new file mode 100644
index 00000000..db871854
--- /dev/null
+++ b/testsuite/external/ocamlnet-3.5.1.patch
@@ -0,0 +1,41 @@
+--- ocamlnet-3.5.1.orig/src/netsys/netsys_posix.ml	2011-10-12 14:09:05.000000000 +0200
++++ ocamlnet-3.5.1/src/netsys/netsys_posix.ml	2012-01-12 19:33:39.000000000 +0100
+@@ -412,9 +412,11 @@
+ type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_REMOVEDIR
+ 
+ (* The stubs assume these type definitions: *)
++(* In fact, they don't: they assume OCaml's stdlib definition
+ type open_flag1 = Unix.open_flag =
+     O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
+   | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC
++*)
+ 
+ type access_permission1 = Unix.access_permission =
+     R_OK | W_OK | X_OK | F_OK
+--- ocamlnet-3.5.1.orig/src/netstring/Makefile.def	2012-02-29 19:02:52.000000000 +0100
++++ ocamlnet-3.5.1/src/netstring/Makefile.def	2012-05-25 16:59:56.000000000 +0200
+@@ -13,7 +13,7 @@
+ PKGNAME  = netstring
+ 
+ REQUIRES = $(REGEXP_PROVIDER) bigarray
+-INCLUDES += $(INC_NETSYS)
++INCLUDES += $(INC_NETSYS) -I +compiler-libs
+ 
+ ISO_MAPPINGS   = mappings/iso*.unimap
+ JP_MAPPINGS    = mappings/jis*.*map
+--- ocamlnet-3.5.1.orig/src/pop/netpop.ml	2012-02-29 19:02:53.000000000 +0100
++++ ocamlnet-3.5.1/src/pop/netpop.ml	2013-06-20 14:06:11.000000000 +0200
+@@ -231,6 +231,7 @@
+ 	  status_response ic parse_line (Hashtbl.create 1)
+     with _ -> raise Protocol_error
+ 
++(*
+   method stat () =
+     self#check_state `Transaction;
+     send_command oc "STAT";
+@@ -242,4 +243,5 @@
+ 	(count, size, ext)
+       )
+     with _ -> raise Protocol_error;
++*)
+ end
diff --git a/testsuite/external/ocsigen-bundle-2.2.2.patch b/testsuite/external/ocsigen-bundle-2.2.2.patch
new file mode 100644
index 00000000..b947999a
--- /dev/null
+++ b/testsuite/external/ocsigen-bundle-2.2.2.patch
@@ -0,0 +1,47 @@
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt ocsigen-bundle-2.2.2/pkg/Makefile.lwt
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt	2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.lwt	2011-12-29 00:34:27.000000000 +0100
+@@ -70,7 +70,7 @@
+ 
+ ${METAS}/META.lwt: ${LWT_DIR}/src/core/META
+ 	echo "directory = \"${srcdir}/${LWT_DIR}/_build/src/core\"" > $@
+-	sed -e 's%^package "\([^\"]*\)" (%package "\1" (\n directory = "../\1"%g' \
++	sed -e 's%^package "\([^\"]*\)" (%package "\1" ( directory = "../\1"%g' \
+ 	    -e 's%../syntax%../../syntax%' \
+ 	  $< >> $@
+ 
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore	2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore	2011-12-29 00:34:51.000000000 +0100
+@@ -37,8 +37,8 @@
+ 
+ ${METAS}/META.ocsimore: ${OCSIMORE_DIR}/src/core/META
+ 	echo "directory = \"${srcdir}/${OCSIMORE_DIR}/_build/src/core\"" > $@
+-	sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" (\n directory = "../\2"%g' \
+-	    -e 's%^package "site_client" (%package "site_client" (\n directory = "../site/client"%g' \
++	sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" ( directory = "../\2"%g' \
++	    -e 's%^package "site_client" (%package "site_client" ( directory = "../site/client"%g' \
+ 	  $< >> $@
+ 
+ 
+diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.tyxml ocsigen-bundle-2.2.2/pkg/Makefile.tyxml
+--- ocsigen-bundle-2.2.2.orig/pkg/Makefile.js_of_ocaml	2011-12-20 16:13:24.000000000 +0100
++++ ocsigen-bundle-2.2.2/pkg/Makefile.js_of_ocaml	2011-12-29 01:47:00.000000000 +0100
+@@ -47,5 +47,5 @@
+ 
+ ${METAS}/META.js_of_ocaml: ${JS_OF_OCAML_DIR}/lib/META
+ 	echo "directory = \"${srcdir}/${JS_OF_OCAML_DIR}/lib\"" > $@
+-	sed -e 's%package "syntax" (%package "syntax" (\n directory = "syntax"%g' \
++	sed -e 's%package "syntax" (%package "syntax" ( directory = "syntax"%g' \
+ 	  $< >> $@
+--- ocsigen-bundle-2.2.2/configure.orig	2012-05-25 18:33:10.000000000 +0200
++++ ocsigen-bundle-2.2.2/configure	2012-05-25 18:33:24.000000000 +0200
+@@ -11051,7 +11051,7 @@
+ 
+ 
+ 
+-build_projects="deriving-ocsigen lwt js_of_ocaml tyxml ocsigenserver eliom"
++build_projects="deriving-ocsigen js_of_ocaml tyxml ocsigenserver"
+ if  test $enable_ocsimore = yes ; then :
+    build_projects+=" ocsimore"
+ fi
diff --git a/testsuite/external/omake-0.9.8.6.patch b/testsuite/external/omake-0.9.8.6.patch
new file mode 100644
index 00000000..9fd8a7a0
--- /dev/null
+++ b/testsuite/external/omake-0.9.8.6.patch
@@ -0,0 +1,11 @@
+--- omake-0.9.8.6.orig/lib/build/OCaml.om	2008-03-05 02:07:25.000000000 +0100
++++ omake-0.9.8.6/lib/build/OCaml.om	2011-05-02 22:53:23.000000000 +0200
+@@ -176,7 +176,7 @@
+ #
+ declare OCAMLDEPFLAGS
+ public.OCAMLPPFLAGS  =
+-public.OCAMLFLAGS    = -warn-error A
++public.OCAMLFLAGS    = -warn-error a
+ public.OCAMLCFLAGS   = -g
+ public.OCAMLOPTFLAGS =
+ public.OCAMLCPPFLAGS =
diff --git a/testsuite/external/sks-1.1.3.patch b/testsuite/external/sks-1.1.3.patch
new file mode 100644
index 00000000..d5995340
--- /dev/null
+++ b/testsuite/external/sks-1.1.3.patch
@@ -0,0 +1,20 @@
+diff -N -r -u sks-1.1.3.orig/Makefile.local sks-1.1.3/Makefile.local
+--- sks-1.1.3.orig/Makefile.local	1970-01-01 01:00:00.000000000 +0100
++++ sks-1.1.3/Makefile.local	2010-05-17 14:49:16.000000000 +0200
+@@ -0,0 +1,5 @@
++LIBDB=-ldb
++MANDIR=${PREFIX}/share/man
++export PREFIX
++export LIBDB
++export MANDIR
+--- sks-1.1.3.orig/Makefile	2012-04-11 04:03:25.000000000 +0200
++++ sks-1.1.3/Makefile	2013-05-30 14:40:03.000000000 +0200
+@@ -47,7 +47,7 @@
+ 
+ CAMLP4=-pp $(CAMLP4O)
+ CAMLINCLUDE= -I lib -I bdb
+-COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error A
++COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error a
+ OCAMLDEP=ocamldep $(CAMLP4) 
+ CAMLLIBS=unix.cma str.cma bdb.cma nums.cma bigarray.cma cryptokit.cma
+ OCAMLFLAGS=$(COMMONCAMLFLAGS) -g $(CAMLLIBS)
diff --git a/testsuite/external/vsyml-2010-04-06.patch b/testsuite/external/vsyml-2010-04-06.patch
new file mode 100644
index 00000000..a688e7a5
--- /dev/null
+++ b/testsuite/external/vsyml-2010-04-06.patch
@@ -0,0 +1,20 @@
+--- vsyml-2010-04-06.orig/makefile	2010-04-06 19:28:25.000000000 +0200
++++ vsyml-2010-04-06/makefile	2010-08-23 15:16:22.000000000 +0200
+@@ -525,13 +525,13 @@
+ 
+ # dependencies for the symbolic simulator main file on cmo cma cmx and cmxa
+ $(VSYML_CMO_LST): $(VSYML_MAIN)
+-	echo -n "VSYML_CMO=" > $@
+-	for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo -n $$i " " >> $@ ; done
++	echo "VSYML_CMO=" | tr -d '\012' > $@
++	for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done
+ 	echo $(patsubst $(SRC_PATH)$(PATH_SEPARATOR)%.ml,%.cmo,$<) >> $@
+ 
+ $(VSYML_CMA_LST): $(VSYML_MAIN)
+-	echo -n "VSYML_CMA=" > $@
+-	for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo -n $$i " " >> $@ ; done
++	echo "VSYML_CMA=" | tr -d '\012' > $@
++	for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done
+ 
+ $(VSYML_BYTE_CMO_LST): $(VSYML_CMO_LST)
+ 	sed -e 's@\([a-zA-Z0-9_]*\)\.cmo@$(BYTE_PATH)$(PATH_SEPARATOR)\1.cmo@g' -e 's/VSYML_CMO/VSYML_BYTE_CMO/' $< > $@
diff --git a/testsuite/external/xml-light-2.2.patch b/testsuite/external/xml-light-2.2.patch
new file mode 100644
index 00000000..62351908
--- /dev/null
+++ b/testsuite/external/xml-light-2.2.patch
@@ -0,0 +1,19 @@
+--- xml-light/Makefile	2003-10-12 11:16:12.000000000 +0200
++++ xml-light-2.2/Makefile	2010-01-23 20:57:57.000000000 +0100
+@@ -2,7 +2,7 @@
+ # http://tech.motion-twin.com
+ .SUFFIXES : .ml .mli .cmo .cmx .cmi .mll .mly
+ 
+-INSTALLDIR=`ocamlc -where`
++INSTALLDIR=`ocamlc -where`/xml-light
+ CFLAGS=
+ LFLAGS= -a
+ LIBS=
+@@ -12,6 +12,7 @@
+ opt: xml-light.cmxa test_opt.exe
+ 
+ install: all opt
++	mkdir -p "${INSTALLDIR}"
+ 	cp xml-light.cmxa xml-light.a xml-light.cma xml.mli xmlParser.mli dtd.mli xml.cmi xmlParser.cmi dtd.cmi xml.cmx dtd.cmx xmlParser.cmx $(INSTALLDIR)
+ 
+ doc:
diff --git a/testsuite/interactive/lib-gc/Makefile b/testsuite/interactive/lib-gc/Makefile
index 65bd44d1..1e4281fb 100644
--- a/testsuite/interactive/lib-gc/Makefile
+++ b/testsuite/interactive/lib-gc/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 default:
diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml
index 9f6ad1b5..2db80346 100644
--- a/testsuite/interactive/lib-gc/alloc.ml
+++ b/testsuite/interactive/lib-gc/alloc.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: alloc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Random allocation test *)
 
 (*
diff --git a/testsuite/interactive/lib-gc/alloc.result b/testsuite/interactive/lib-gc/alloc.result
deleted file mode 100644
index 9503b34c..00000000
--- a/testsuite/interactive/lib-gc/alloc.result
+++ /dev/null
@@ -1,544 +0,0 @@
-
-minor_words: 6410964
-promoted_words: 6332175
-major_words: 6393661
-minor_collections: 196
-major_collections: 14
-heap_words: 3936256
-heap_chunks: 31
-top_heap_words: 3936256
-live_words: 2034808
-live_blocks: 31786
-free_words: 1901339
-free_blocks: 16531
-largest_free: 1357
-fragments: 109
-compactions: 0
-
-minor_words: 12805330
-promoted_words: 12664909
-major_words: 12739763
-minor_collections: 391
-major_collections: 21
-heap_words: 4571136
-heap_chunks: 36
-top_heap_words: 4571136
-live_words: 2126718
-live_blocks: 33282
-free_words: 2444325
-free_blocks: 19124
-largest_free: 1824
-fragments: 93
-compactions: 0
-
-minor_words: 19215544
-promoted_words: 18998176
-major_words: 19100845
-minor_collections: 586
-major_collections: 28
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2135891
-live_blocks: 33344
-free_words: 2562126
-free_blocks: 19238
-largest_free: 1405
-fragments: 95
-compactions: 0
-
-minor_words: 25638028
-promoted_words: 25361252
-major_words: 25472205
-minor_collections: 782
-major_collections: 35
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2137378
-live_blocks: 33350
-free_words: 2560637
-free_blocks: 19112
-largest_free: 1634
-fragments: 97
-compactions: 0
-
-minor_words: 32062298
-promoted_words: 31721945
-major_words: 31842628
-minor_collections: 978
-major_collections: 41
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2145462
-live_blocks: 33351
-free_words: 2552521
-free_blocks: 19013
-largest_free: 1999
-fragments: 129
-compactions: 0
-
-minor_words: 38449694
-promoted_words: 38049841
-major_words: 38176354
-minor_collections: 1173
-major_collections: 48
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2125014
-live_blocks: 33351
-free_words: 2572992
-free_blocks: 19080
-largest_free: 1525
-fragments: 106
-compactions: 0
-
-minor_words: 44846324
-promoted_words: 44379560
-major_words: 44521194
-minor_collections: 1368
-major_collections: 55
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136556
-live_blocks: 33351
-free_words: 2561444
-free_blocks: 19191
-largest_free: 1760
-fragments: 112
-compactions: 0
-
-minor_words: 51240537
-promoted_words: 50707711
-major_words: 50862160
-minor_collections: 1563
-major_collections: 61
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136623
-live_blocks: 33351
-free_words: 2561383
-free_blocks: 18967
-largest_free: 1526
-fragments: 106
-compactions: 0
-
-minor_words: 57628061
-promoted_words: 57038039
-major_words: 57197286
-minor_collections: 1758
-major_collections: 68
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2133895
-live_blocks: 33351
-free_words: 2564119
-free_blocks: 19273
-largest_free: 1793
-fragments: 98
-compactions: 0
-
-minor_words: 64028127
-promoted_words: 63367620
-major_words: 63545093
-minor_collections: 1953
-major_collections: 74
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2138085
-live_blocks: 33351
-free_words: 2559920
-free_blocks: 19111
-largest_free: 1800
-fragments: 107
-compactions: 0
-
-minor_words: 70438812
-promoted_words: 69698963
-major_words: 69904882
-minor_collections: 2148
-major_collections: 80
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2131008
-live_blocks: 33351
-free_words: 2566995
-free_blocks: 19079
-largest_free: 1451
-fragments: 109
-compactions: 0
-
-minor_words: 76852923
-promoted_words: 76032234
-major_words: 76270123
-minor_collections: 2343
-major_collections: 86
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2135699
-live_blocks: 33351
-free_words: 2562313
-free_blocks: 19201
-largest_free: 2056
-fragments: 100
-compactions: 0
-
-minor_words: 83248665
-promoted_words: 82362663
-major_words: 82613979
-minor_collections: 2538
-major_collections: 92
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2126387
-live_blocks: 33351
-free_words: 2571625
-free_blocks: 19099
-largest_free: 1498
-fragments: 100
-compactions: 0
-
-minor_words: 89636938
-promoted_words: 88694885
-major_words: 88952817
-minor_collections: 2733
-major_collections: 99
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2136754
-live_blocks: 33351
-free_words: 2561246
-free_blocks: 19220
-largest_free: 1697
-fragments: 112
-compactions: 0
-
-minor_words: 96030388
-promoted_words: 95026453
-major_words: 95296004
-minor_collections: 2928
-major_collections: 106
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2126039
-live_blocks: 33351
-free_words: 2571956
-free_blocks: 19250
-largest_free: 1593
-fragments: 117
-compactions: 0
-
-minor_words: 102436652
-promoted_words: 101356198
-major_words: 101649957
-minor_collections: 3123
-major_collections: 113
-heap_words: 4698112
-heap_chunks: 37
-top_heap_words: 4698112
-live_words: 2140261
-live_blocks: 33351
-free_words: 2557747
-free_blocks: 19192
-largest_free: 1731
-fragments: 104
-compactions: 0
-
-minor_words: 108832359
-promoted_words: 107686065
-major_words: 107994506
-minor_collections: 3318
-major_collections: 119
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2124817
-live_blocks: 33351
-free_words: 2700160
-free_blocks: 19149
-largest_free: 1617
-fragments: 111
-compactions: 0
-
-minor_words: 115220373
-promoted_words: 114018413
-major_words: 114333086
-minor_collections: 3513
-major_collections: 125
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2124190
-live_blocks: 33351
-free_words: 2700795
-free_blocks: 19303
-largest_free: 1567
-fragments: 103
-compactions: 0
-
-minor_words: 121628396
-promoted_words: 120347328
-major_words: 120688494
-minor_collections: 3708
-major_collections: 131
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133563
-live_blocks: 33351
-free_words: 2691408
-free_blocks: 19134
-largest_free: 2129
-fragments: 117
-compactions: 0
-
-minor_words: 128038304
-promoted_words: 126675491
-major_words: 127045570
-minor_collections: 3903
-major_collections: 137
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2135379
-live_blocks: 33351
-free_words: 2689601
-free_blocks: 19345
-largest_free: 1699
-fragments: 108
-compactions: 0
-
-minor_words: 134429672
-promoted_words: 133007487
-major_words: 133387404
-minor_collections: 4098
-major_collections: 143
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2127333
-live_blocks: 33351
-free_words: 2697647
-free_blocks: 19276
-largest_free: 1758
-fragments: 108
-compactions: 0
-
-minor_words: 140831438
-promoted_words: 139333508
-major_words: 139733383
-minor_collections: 4293
-major_collections: 149
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2145113
-live_blocks: 33351
-free_words: 2679876
-free_blocks: 19365
-largest_free: 1650
-fragments: 99
-compactions: 0
-
-minor_words: 147229656
-promoted_words: 145661743
-major_words: 146077858
-minor_collections: 4488
-major_collections: 155
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2132556
-live_blocks: 33351
-free_words: 2692441
-free_blocks: 19150
-largest_free: 1431
-fragments: 91
-compactions: 0
-
-minor_words: 153646155
-promoted_words: 152024536
-major_words: 152442636
-minor_collections: 4684
-major_collections: 161
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130394
-live_blocks: 33351
-free_words: 2694592
-free_blocks: 19164
-largest_free: 1288
-fragments: 102
-compactions: 0
-
-minor_words: 160038986
-promoted_words: 158352855
-major_words: 158781961
-minor_collections: 4879
-major_collections: 167
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2131838
-live_blocks: 33351
-free_words: 2693140
-free_blocks: 19355
-largest_free: 1741
-fragments: 110
-compactions: 0
-
-minor_words: 166458940
-promoted_words: 164714552
-major_words: 165149249
-minor_collections: 5075
-major_collections: 173
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2146731
-live_blocks: 33351
-free_words: 2678258
-free_blocks: 19338
-largest_free: 1951
-fragments: 99
-compactions: 0
-
-minor_words: 172869183
-promoted_words: 171044208
-major_words: 171507681
-minor_collections: 5270
-major_collections: 179
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130620
-live_blocks: 33351
-free_words: 2694346
-free_blocks: 19355
-largest_free: 1716
-fragments: 122
-compactions: 0
-
-minor_words: 179276123
-promoted_words: 177371439
-major_words: 177859651
-minor_collections: 5465
-major_collections: 185
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2141174
-live_blocks: 33351
-free_words: 2683827
-free_blocks: 19340
-largest_free: 1707
-fragments: 87
-compactions: 0
-
-minor_words: 185681086
-promoted_words: 183702557
-major_words: 184213391
-minor_collections: 5660
-major_collections: 191
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133699
-live_blocks: 33351
-free_words: 2691284
-free_blocks: 19303
-largest_free: 1557
-fragments: 105
-compactions: 0
-
-minor_words: 192087937
-promoted_words: 190033229
-major_words: 190568763
-minor_collections: 5855
-major_collections: 197
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2133162
-live_blocks: 33351
-free_words: 2691831
-free_blocks: 19299
-largest_free: 1561
-fragments: 95
-compactions: 0
-
-minor_words: 198496824
-promoted_words: 196364203
-major_words: 196926470
-minor_collections: 6050
-major_collections: 203
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2129841
-live_blocks: 33351
-free_words: 2695139
-free_blocks: 19163
-largest_free: 1653
-fragments: 108
-compactions: 0
-
-minor_words: 204889797
-promoted_words: 202693452
-major_words: 203267275
-minor_collections: 6245
-major_collections: 209
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2130715
-live_blocks: 33351
-free_words: 2694271
-free_blocks: 19257
-largest_free: 1491
-fragments: 102
-compactions: 0
-
-minor_words: 211268811
-promoted_words: 208990042
-major_words: 209593734
-minor_collections: 6439
-major_collections: 215
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2128683
-live_blocks: 33351
-free_words: 2696320
-free_blocks: 19306
-largest_free: 1789
-fragments: 85
-compactions: 0
-
-minor_words: 217673548
-promoted_words: 215319820
-major_words: 215946607
-minor_collections: 6634
-major_collections: 221
-heap_words: 4825088
-heap_chunks: 38
-top_heap_words: 4825088
-live_words: 2134523
-live_blocks: 33351
-free_words: 2690457
-free_blocks: 19391
-largest_free: 1845
-fragments: 108
-compactions: 0
diff --git a/testsuite/interactive/lib-graph-2/Makefile b/testsuite/interactive/lib-graph-2/Makefile
index 9a5c0c5f..836fd90b 100644
--- a/testsuite/interactive/lib-graph-2/Makefile
+++ b/testsuite/interactive/lib-graph-2/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_test
diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile
index 6f0660a9..dd47b82d 100644
--- a/testsuite/interactive/lib-graph-3/Makefile
+++ b/testsuite/interactive/lib-graph-3/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=sorts
diff --git a/testsuite/interactive/lib-graph-3/sorts.ml b/testsuite/interactive/lib-graph-3/sorts.ml
index abc8dc1b..126463d2 100644
--- a/testsuite/interactive/lib-graph-3/sorts.ml
+++ b/testsuite/interactive/lib-graph-3/sorts.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Animation of sorting algorithms. *)
 
 open Graphics
diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile
index 61f472b3..18e90ac0 100644
--- a/testsuite/interactive/lib-graph/Makefile
+++ b/testsuite/interactive/lib-graph/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_example
diff --git a/testsuite/interactive/lib-graph/graph_example.ml b/testsuite/interactive/lib-graph/graph_example.ml
index 6fbe988c..09f4e4ca 100644
--- a/testsuite/interactive/lib-graph/graph_example.ml
+++ b/testsuite/interactive/lib-graph/graph_example.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* To run this example:
    ********************
    1. Select all the text in this window.
diff --git a/testsuite/interactive/lib-signals/Makefile b/testsuite/interactive/lib-signals/Makefile
index ec22e068..2751a8b1 100644
--- a/testsuite/interactive/lib-signals/Makefile
+++ b/testsuite/interactive/lib-signals/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 default:
diff --git a/testsuite/interactive/lib-signals/signals.ml b/testsuite/interactive/lib-signals/signals.ml
index 8a5c4e0c..c60f59c6 100644
--- a/testsuite/interactive/lib-signals/signals.ml
+++ b/testsuite/interactive/lib-signals/signals.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rec tak (x, y, z) =
   if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
            else z
diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile
index 11518f6e..3c0ad6a6 100644
--- a/testsuite/lib/Makefile
+++ b/testsuite/lib/Makefile
@@ -1,14 +1,28 @@
-# $Id: Makefile 12239 2012-03-14 10:22:02Z xclerc $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
+.PHONY: compile
 compile: compile-targets
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
 
 include ../makefiles/Makefile.common
 
+.PHONY: compile-targets
 compile-targets: testing.cmi testing.cmo
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	@if $(BYTECODE_ONLY); then : ; else \
 	  $(MAKE) testing.cmx; \
 	fi
diff --git a/testsuite/lib/empty b/testsuite/lib/empty
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml
index 6398f754..0791fa7e 100644
--- a/testsuite/lib/testing.ml
+++ b/testsuite/lib/testing.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: testing.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Testing auxilliaries. *)
 
 open Scanf;;
diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli
index 866193ff..68440f72 100644
--- a/testsuite/lib/testing.mli
+++ b/testsuite/lib/testing.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: testing.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Testing auxilliaries. *)
 
 val test : bool -> unit;;
diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index 16defec7..9d2716d6 100644
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -1,26 +1,73 @@
-# $Id: Makefile.common 12551 2012-06-04 11:40:59Z doligez $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
 TOPDIR=$(BASEDIR)/..
+WINTOPDIR=`cygpath -m "$(TOPDIR)"`
 
-include $(TOPDIR)/config/Makefile
+# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
+# WINTOPDIR is the same directory, in Windows syntax.
 
+OTOPDIR=$(TOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=echo
 DIFF=diff -q
-BOOTDIR=$(TOPDIR)/boot
-OCAMLRUN=$(BOOTDIR)/ocamlrun$(EXE)
-OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml -I $(TOPDIR)/stdlib
-OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib
-OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib
-OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc
-OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex
-OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib
+CANKILL=true
+SORT=sort
+SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
+
+# The variables above may be overridden by .../config/Makefile
+# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the OCaml compiler.
+# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the C and Fortran compilers.
+# CYGPATH is the command that translates unix-style file names into
+#   whichever syntax is appropriate for arguments of OCaml programs.
+# DIFF is a "diff -q" command that ignores trailing CRs under Windows.
+# CANKILL is true if a script launched by Make can kill an OCaml process,
+#   and false for the mingw and MSVC ports.
+# SORT is the Unix "sort" command. Usually a simple command, but may be an
+#   absolute name if the Windows "sort" command is in the PATH.
+# SET_LD_PATH is a command prefix that sets the path for dynamic libraries
+#   (LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
+#   variable. Note that for Windows we add Unix-syntax directory names in
+#   PATH, and Cygwin will translate it to Windows syntax.
+
+include $(TOPDIR)/config/Makefile
+
+OCAMLRUN=$(TOPDIR)/boot/ocamlrun$(EXE)
+
+OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \
+      -init $(OTOPDIR)/testsuite/lib/empty
+OCAMLC=$(OCAMLRUN) $(OTOPDIR)/ocamlc $(OCFLAGS)
+OCAMLOPT=$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS)
+OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc
+OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex
+OCAMLMKLIB=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \
+		       -ocamlc "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+		                $(OTOPDIR)/ocamlc $(OCFLAGS)" \
+		       -ocamlopt "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+		                  $(OTOPDIR)/ocamlopt $(OCFLAGS)"
 OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
 OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native
-DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj
-BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi`
-#COMPFLAGS=
+DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tool/dumpobj
+BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
+
 #FORTRAN_COMPILER=
 #FORTRAN_LIBRARY=
 
+UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`
+
 defaultpromote:
 	@for file in *.reference; do \
 	  cp `basename $$file reference`result $$file; \
@@ -35,26 +82,26 @@ defaultclean:
 	done
 
 .SUFFIXES:
-.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so
+.SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so .c .f
 
 .mli.cmi:
-	@$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+	@$(OCAMLC) -c $(ADD_COMPFLAGS) $<
 
 .ml.cmi:
-	@$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $<
+	@$(OCAMLC) -c $(ADD_COMPFLAGS) $<
 
 .ml.cmo:
-	@if [ -f $ /dev/null
@@ -64,10 +111,16 @@ defaultclean:
 
 .cmm.o:
 	@$(OCAMLRUN) ./codegen $*.cmm > $*.s
-	@$(AS) $(ASFLAGS) -o $*.o $*.s
+	@$(ASM) -o $*.o $*.s
 
 .S.o:
 	@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.S
 
 .s.o:
 	@$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s
+
+.c.o:
+	@$(CC) -c -I$(CTOPDIR)/byterun $*.c -o $*.$(O)
+
+.f.o:
+	@$(FORTRAN_COMPILER) -c -I$(CTOPDIR)/byterun $*.f -o $*.$(O)
diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
index 7501aeab..11ddf95c 100644
--- a/testsuite/makefiles/Makefile.okbad
+++ b/testsuite/makefiles/Makefile.okbad
@@ -1,21 +1,42 @@
-# $Id: Makefile.okbad 11965 2011-12-28 08:47:03Z xleroy $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
+.PHONY: default
 default: compile
 
+.PHONY: compile
 compile:
 	@for file in *.ml; do \
 	  printf " ... testing '$$file'"; \
 	  if [ `echo $$file | grep bad` ]; then \
-	    $(OCAMLC) -c -w a $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \
+	    $(OCAMLC) -c -w a $$file 2>/dev/null \
+            && echo " => failed" || echo " => passed"; \
 	  else \
-	    test -f `basename $$file ml`mli && $(OCAMLC) -c -w a `basename $$file ml`mli; \
-	    $(OCAMLC) -c -w a $$file 2> /dev/null || (echo " => failed" && exit 1); \
-	    test -f `basename $$file ml`reference && $(OCAMLC) `basename $$file ml`cmo && ./a.out > `basename $$file ml`result && ($(DIFF) `basename $$file ml`reference `basename $$file ml`result || (echo " => failed" && exit 1)); \
-	    echo " => passed"; \
+	    F="`basename $$file .ml`"; \
+	    test -f $$F.mli && $(OCAMLC) -c -w a $$F.mli; \
+	    $(OCAMLC) -c -w a $$file 2>/dev/null \
+	    && if [ -f $$F.reference ]; then \
+	         rm -f program.byte; \
+	         $(OCAMLC) $$F.cmo -o program.byte \
+	         && $(OCAMLRUN) program.byte >$$F.result \
+	         && $(DIFF) $$F.reference $$F.result >/dev/null; \
+	       fi \
+	    && echo " => passed" || echo " => failed"; \
 	  fi; \
 	done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f ./a.out *.cm* *.result
+	@rm -f program.byte *.cm* *.result
diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
index 9a7c5278..16d02e8e 100644
--- a/testsuite/makefiles/Makefile.one
+++ b/testsuite/makefiles/Makefile.one
@@ -1,4 +1,14 @@
-# $Id: Makefile.one 12649 2012-06-27 12:29:20Z doligez $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
 CMI_FILES=$(MODULES:=.cmi)
 CMO_FILES=$(MODULES:=.cmo)
@@ -9,41 +19,58 @@ ML_LEX_FILES=$(LEX_MODULES:=.ml)
 ML_YACC_FILES=$(YACC_MODULES:=.ml)
 MLI_YACC_FILES=$(YACC_MODULES:=.mli)
 ML_FILES=$(ML_LEX_FILES) $(ML_YACC_FILES)
-O_FILES=$(C_FILES:=.o)
+O_FILES=$(C_FILES:=.$(O))
 ADD_CMO_FILES=$(ADD_MODULES:=.cmo)
 ADD_CMX_FILES=$(ADD_MODULES:=.cmx)
 
 GENERATED_SOURCES=$(ML_LEX_FILES) $(ML_YACC_FILES) $(MLI_YACC_FILES)
 
-CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi`
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
 ADD_CFLAGS+=$(CUSTOM_FLAG)
+MYRUNTIME=`if [ -z "$(C_FILES)" ]; then echo '$(OCAMLRUN)'; fi`
 
-default: compile run
+CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
 
+.PHONY: default
+default:
+	@$(SET_LD_PATH) $(MAKE) compile run
+
+.PHONY: compile
 compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo
 	@for file in $(C_FILES); do \
-	  $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \
+	  $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(CTOPDIR)/byterun $$file.c; \
 	done;
 	@rm -f program.byte program.byte.exe
-	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	@$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
+	           $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \
+	           $(MAIN_MODULE).cmo
+	@if $(BYTECODE_ONLY); then : ; else \
 	  rm -f program.native program.native.exe; \
 	  $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \
-	  $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \
+	  $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native$(EXE) $(O_FILES) \
+	              $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) \
+	              $(MAIN_MODULE).cmx; \
 	fi
 
+.PHONY: run
 run:
 	@printf " ... testing with ocamlc"
-	@./program.byte $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
-	@$(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
-	  printf " ocamlopt"; \
-	  ./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1); \
-	  $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1); \
-	fi
-	@echo " => passed"
+	@$(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) >$(MAIN_MODULE).result\
+	&& $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \
+	&& if $(BYTECODE_ONLY); then : ; else \
+	     printf " ocamlopt"; \
+	     ./program.native$(EXE) $(EXEC_ARGS) > $(MAIN_MODULE).result \
+	     && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+	                >/dev/null; \
+	   fi \
+	&& echo " => passed" || echo " => failed"
+
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.result ./program.* $(GENERATED_SOURCES) $(O_FILES)
+	@rm -f *.result program.byte program.byte.exe \
+	       program.native program.native.exe \
+	       $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES)
diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index 54df8236..d4a5caac 100644
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -1,4 +1,14 @@
-# $Id: Makefile.several 12618 2012-06-19 14:17:41Z doligez $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
 CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
 FC=$(FORTAN_COMPILER)
@@ -8,15 +18,20 @@ CMA_FILES=$(LIBRARIES:=.cma)
 CMXA_FILES=$(LIBRARIES:=.cmxa)
 O_FILES=$(C_FILES:=.o)
 
-CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi`
+CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi`
 ADD_CFLAGS+=$(CUSTOM_FLAG)
-FORTRAN_LIB=`if [ -z "$(F_FILES)" ]; then true; else echo '$(FORTRAN_LIBRARY)'; fi`
+MYRUNTIME=`if [ -z "$(C_FILES)" ]; then echo '$(OCAMLRUN)'; fi`
+FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo '$(FORTRAN_LIBRARY)'; fi`
 ADD_CFLAGS+=$(FORTRAN_LIB)
 ADD_OPTFLAGS+=$(FORTRAN_LIB)
 
+.PHONY: check
 check:
-	@if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then $(MAKE) run-all; fi
+	@if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then \
+	  $(SET_LD_PATH) $(MAKE) run-all; \
+	fi
 
+.PHONY: run-all
 run-all:
 	@for file in $(C_FILES); do \
 	  $(CC) -c -I$(PREFIX)/lib/ocaml/caml $$file.c; \
@@ -25,36 +40,67 @@ run-all:
 	  $(FORTRAN_COMPILER) -c -I$(PREFIX)/lib/ocaml/caml $$file.f; \
 	done;
 	@for file in *.ml; do \
+	  if [ -f `basename $$file ml`precheck ]; then \
+	    CANKILL=$(CANKILL) sh `basename $$file ml`precheck || continue; \
+	  fi; \
 	  printf " ... testing '$$file':"; \
-	  $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
-	  if [ -z "$(BYTECODE_ONLY)" ]; then \
-	    $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
-	  fi && \
-	  if [ ! -z $(UNSAFE) ]; then \
-	    $(MAKE) run-file DESC=ocamlc-unsafe COMP=$(PREFIX)/bin/ocamlc COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file && \
-	    if [ -z "$(BYTECODE_ONLY)" ]; then \
-	      $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file; \
-	    fi; \
-	  fi && \
-	  echo " => passed"; \
-	done;
+	  $(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 $(BYTECODE_ONLY); then : ; else \
+	    $(MAKE) run-file DESC=ocamlopt COMP='$(OCAMLOPT)' \
+	            RUNTIME= \
+	            COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_OPTFLAGS) \
+		               $(O_FILES) $(CMXA_FILES) \
+			       -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+	            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) \
+	                       $(O_FILES) $(CMA_FILES) \
+	                       -I $(OTOPDIR)/testsuite/lib $(CMO_FILES)' \
+	            FILE=$$file \
+	    && \
+	    if $(BYTECODE_ONLY); then : ; else \
+	      $(MAKE) run-file DESC=ocamlopt-unsafe COMP='$(OCAMLOPT)' \
+	              RUNTIME= \
+	              COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_OPTFLAGS)\
+		                 $(O_FILES) $(CMXA_FILES) \
+	                         -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
+	              FILE=$$file; \
+	       fi; \
+	     fi \
+	  && echo " => passed" || echo " => failed"; \
+	done
 
+.PHONY: run-file
 run-file:
 	@printf " $(DESC)"
 	@rm -f program program.exe
-	@$(COMP) $(COMPFLAGS) $(FILE) -o program
-	@if [ -f `basename $(FILE) ml`runner ]; then \
-	  sh `basename $(FILE) ml`runner; \
+	@$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
+	@F="`basename $(FILE) .ml`"; \
+	if [ -f $$F.runner ]; then \
+	  RUNTIME="$(RUNTIME)" sh $$F.runner; \
 	else \
-	  ./program $(PROGRAM_ARGS) > `basename $(FILE) ml`result; \
-	fi || (echo " => failed" && exit 1)
-	@if [ -f `basename $(FILE) ml`checker ]; then \
-	  sh `basename $(FILE) ml`checker; \
+	  $(RUNTIME) ./program$(EXE) $(PROGRAM_ARGS) >$$F.result; \
+	fi \
+	&& \
+	if [ -f $$F.checker ]; then \
+	  DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker; \
 	else \
-	  $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null; \
-	fi || (echo " => failed" && exit 1)
+	  $(DIFF) $$F.reference $$F.result >/dev/null; \
+	fi
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.result ./program program.exe
+	@rm -f *.result program program.exe
diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel
index b50dc1bf..46acb3d7 100644
--- a/testsuite/makefiles/Makefile.toplevel
+++ b/testsuite/makefiles/Makefile.toplevel
@@ -1,15 +1,28 @@
-# $Id: Makefile.toplevel 11965 2011-12-28 08:47:03Z xleroy $
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
 
 default:
 	@for file in *.ml; do \
-	  $(OCAML) < $$file 2>&1 | grep -v '^        OCaml version' > $$file.result; \
+	  $(OCAML) $(TOPFLAGS) <$$file 2>&1 \
+	    | grep -v '^        OCaml version' > $$file.result; \
 	  if [ -f $$file.principal.reference ]; then \
-	    $(OCAML) -principal < $$file 2>&1 | grep -v '^        OCaml version' > $$file.principal.result; \
+	    $(OCAML) $(TOPFLAGS) -principal <$$file 2>&1 \
+	      | grep -v '^        OCaml version' > $$file.principal.result; \
 	  fi; \
 	done
 	@for file in *.reference; do \
 	  printf " ... testing '$$file':"; \
-	  $(DIFF) $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
+	  $(DIFF) $$file `basename $$file reference`result >/dev/null \
+          && echo " => passed" || echo " => failed"; \
 	done
 
 promote: defaultpromote
diff --git a/testsuite/makefiles/summarize.awk b/testsuite/makefiles/summarize.awk
new file mode 100644
index 00000000..75ab9525
--- /dev/null
+++ b/testsuite/makefiles/summarize.awk
@@ -0,0 +1,117 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+function check() {
+    if (!in_test){
+        printf("error at line %d: found test result without test start\n", NR);
+        errored = 1;
+    }
+}
+
+function clear() {
+    curfile = "";
+    in_test = 0;
+}
+
+function record_pass() {
+    check();
+    ++ passed;
+    clear();
+}
+
+function record_skip() {
+    check();
+    ++ skipped;
+    clear();
+}
+
+function record_fail() {
+    check();
+    ++ failed;
+    fail[failidx++] = sprintf ("%s/%s", curdir, curfile);
+    clear();
+}
+
+function record_unexp() {
+    ++ unexped;
+    unexp[unexpidx++] = sprintf ("%s/%s", curdir, curfile);
+    clear();
+}
+
+/Running tests from '[^']*'/ {
+    if (in_test) record_unexp();
+    match($0, /Running tests from '[^']*'/);
+    curdir = substr($0, RSTART+20, RLENGTH - 21);
+    curfile = "";
+}
+
+/ ... testing.* ... testing/ {
+    printf("error at line %d: found two test results on the same line\n", NR);
+    errored = 1;
+}
+
+/^ ... testing '[^']*'/ {
+    if (in_test) record_unexp();
+    match($0, /... testing '[^']*'/);
+    curfile = substr($0, RSTART+13, RLENGTH-14);
+    in_test = 1;
+}
+
+/^ ... testing with / {
+    if (in_test) record_unexp();
+    in_test = 1;
+}
+
+/=> passed/ {
+    record_pass();
+}
+
+/=> skipped/ {
+    record_skip();
+}
+
+/=> failed/ {
+    record_fail();
+}
+
+/=> unexpected error/ {
+    record_unexp();
+}
+
+# Not displaying "skipped" for the moment, as most of the skipped tests
+# print nothing at all and are not counted.
+
+END {
+    if (errored){
+        printf ("\n#### Some fatal error occurred during testing.\n\n");
+        exit (3);
+    }else{
+        printf("\n");
+        printf("Summary:\n");
+        printf("  %3d test(s) passed\n", passed);
+        printf("  %3d test(s) failed\n", failed);
+        printf("  %3d unexpected error(s)\n", unexped);
+        if (failed != 0){
+            printf("\nList of failed tests:\n");
+            for (i=0; i < failed; i++) printf("    %s\n", fail[i]);
+        }
+        if (unexped != 0){
+            printf("\nList of unexpected errors:\n");
+            for (i=0; i < unexped; i++) printf("    %s\n", unexp[i]);
+        }
+        printf("\n");
+        if (failed || unexped){
+            printf("#### Some tests failed. Exiting with error status.\n\n");
+            exit 4;
+        }
+    }
+}
diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
index 8143873d..fd01d336 100644
--- a/testsuite/tests/asmcomp/Makefile
+++ b/testsuite/tests/asmcomp/Makefile
@@ -1,103 +1,117 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 CC=$(NATIVECC)
 CFLAGS=$(NATIVECCCOMPOPTS) -g
 
 INCLUDES=\
-  -I $(TOPDIR)/utils \
-  -I $(TOPDIR)/typing \
-  -I $(TOPDIR)/bytecomp \
-  -I $(TOPDIR)/asmcomp
+  -I $(OTOPDIR)/utils \
+  -I $(OTOPDIR)/typing \
+  -I $(OTOPDIR)/bytecomp \
+  -I $(OTOPDIR)/asmcomp
 
 OTHEROBJS=\
-  $(TOPDIR)/utils/misc.cmo \
-  $(TOPDIR)/utils/tbl.cmo \
-  $(TOPDIR)/utils/config.cmo \
-  $(TOPDIR)/utils/clflags.cmo \
-  $(TOPDIR)/utils/terminfo.cmo \
-  $(TOPDIR)/utils/ccomp.cmo \
-  $(TOPDIR)/utils/warnings.cmo \
-  $(TOPDIR)/utils/consistbl.cmo \
-  $(TOPDIR)/parsing/location.cmo \
-  $(TOPDIR)/parsing/longident.cmo \
-  $(TOPDIR)/parsing/syntaxerr.cmo \
-  $(TOPDIR)/parsing/parser.cmo \
-  $(TOPDIR)/parsing/lexer.cmo \
-  $(TOPDIR)/parsing/parse.cmo \
-  $(TOPDIR)/parsing/printast.cmo \
-  $(TOPDIR)/typing/ident.cmo \
-  $(TOPDIR)/typing/path.cmo \
-  $(TOPDIR)/typing/primitive.cmo \
-  $(TOPDIR)/typing/types.cmo \
-  $(TOPDIR)/typing/btype.cmo \
-  $(TOPDIR)/typing/oprint.cmo \
-  $(TOPDIR)/typing/subst.cmo \
-  $(TOPDIR)/typing/predef.cmo \
-  $(TOPDIR)/typing/datarepr.cmo \
-  $(TOPDIR)/typing/cmi_format.cmo \
-  $(TOPDIR)/typing/env.cmo \
-  $(TOPDIR)/typing/typedtree.cmo \
-  $(TOPDIR)/typing/ctype.cmo \
-  $(TOPDIR)/typing/printtyp.cmo \
-  $(TOPDIR)/typing/includeclass.cmo \
-  $(TOPDIR)/typing/mtype.cmo \
-  $(TOPDIR)/typing/includecore.cmo \
-  $(TOPDIR)/typing/includemod.cmo \
-  $(TOPDIR)/typing/parmatch.cmo \
-  $(TOPDIR)/typing/typetexp.cmo \
-  $(TOPDIR)/typing/cmt_format.cmo \
-  $(TOPDIR)/typing/stypes.cmo \
-  $(TOPDIR)/typing/typecore.cmo \
-  $(TOPDIR)/typing/typedecl.cmo \
-  $(TOPDIR)/typing/typeclass.cmo \
-  $(TOPDIR)/typing/typemod.cmo \
-  $(TOPDIR)/bytecomp/lambda.cmo \
-  $(TOPDIR)/bytecomp/printlambda.cmo \
-  $(TOPDIR)/bytecomp/typeopt.cmo \
-  $(TOPDIR)/bytecomp/switch.cmo \
-  $(TOPDIR)/bytecomp/matching.cmo \
-  $(TOPDIR)/bytecomp/translobj.cmo \
-  $(TOPDIR)/bytecomp/translcore.cmo \
-  $(TOPDIR)/bytecomp/translclass.cmo \
-  $(TOPDIR)/bytecomp/translmod.cmo \
-  $(TOPDIR)/bytecomp/simplif.cmo \
-  $(TOPDIR)/bytecomp/runtimedef.cmo \
-  $(TOPDIR)/asmcomp/arch.cmo \
-  $(TOPDIR)/asmcomp/debuginfo.cmo \
-  $(TOPDIR)/asmcomp/cmm.cmo \
-  $(TOPDIR)/asmcomp/printcmm.cmo \
-  $(TOPDIR)/asmcomp/reg.cmo \
-  $(TOPDIR)/asmcomp/mach.cmo \
-  $(TOPDIR)/asmcomp/proc.cmo \
-  $(TOPDIR)/asmcomp/clambda.cmo \
-  $(TOPDIR)/asmcomp/compilenv.cmo \
-  $(TOPDIR)/asmcomp/closure.cmo \
-  $(TOPDIR)/asmcomp/cmmgen.cmo \
-  $(TOPDIR)/asmcomp/printmach.cmo \
-  $(TOPDIR)/asmcomp/selectgen.cmo \
-  $(TOPDIR)/asmcomp/selection.cmo \
-  $(TOPDIR)/asmcomp/comballoc.cmo \
-  $(TOPDIR)/asmcomp/liveness.cmo \
-  $(TOPDIR)/asmcomp/spill.cmo \
-  $(TOPDIR)/asmcomp/split.cmo \
-  $(TOPDIR)/asmcomp/interf.cmo \
-  $(TOPDIR)/asmcomp/coloring.cmo \
-  $(TOPDIR)/asmcomp/reloadgen.cmo \
-  $(TOPDIR)/asmcomp/reload.cmo \
-  $(TOPDIR)/asmcomp/printlinear.cmo \
-  $(TOPDIR)/asmcomp/linearize.cmo \
-  $(TOPDIR)/asmcomp/schedgen.cmo \
-  $(TOPDIR)/asmcomp/scheduling.cmo \
-  $(TOPDIR)/asmcomp/emitaux.cmo \
-  $(TOPDIR)/asmcomp/emit.cmo \
-  $(TOPDIR)/asmcomp/asmgen.cmo
+  $(OTOPDIR)/utils/misc.cmo \
+  $(OTOPDIR)/utils/tbl.cmo \
+  $(OTOPDIR)/utils/config.cmo \
+  $(OTOPDIR)/utils/clflags.cmo \
+  $(OTOPDIR)/utils/terminfo.cmo \
+  $(OTOPDIR)/utils/ccomp.cmo \
+  $(OTOPDIR)/utils/warnings.cmo \
+  $(OTOPDIR)/utils/consistbl.cmo \
+  $(OTOPDIR)/parsing/location.cmo \
+  $(OTOPDIR)/parsing/longident.cmo \
+  $(OTOPDIR)/parsing/syntaxerr.cmo \
+  $(OTOPDIR)/parsing/parser.cmo \
+  $(OTOPDIR)/parsing/lexer.cmo \
+  $(OTOPDIR)/parsing/parse.cmo \
+  $(OTOPDIR)/parsing/printast.cmo \
+  $(OTOPDIR)/typing/ident.cmo \
+  $(OTOPDIR)/typing/path.cmo \
+  $(OTOPDIR)/typing/primitive.cmo \
+  $(OTOPDIR)/typing/types.cmo \
+  $(OTOPDIR)/typing/btype.cmo \
+  $(OTOPDIR)/typing/oprint.cmo \
+  $(OTOPDIR)/typing/subst.cmo \
+  $(OTOPDIR)/typing/predef.cmo \
+  $(OTOPDIR)/typing/datarepr.cmo \
+  $(OTOPDIR)/typing/cmi_format.cmo \
+  $(OTOPDIR)/typing/env.cmo \
+  $(OTOPDIR)/typing/typedtree.cmo \
+  $(OTOPDIR)/typing/ctype.cmo \
+  $(OTOPDIR)/typing/printtyp.cmo \
+  $(OTOPDIR)/typing/includeclass.cmo \
+  $(OTOPDIR)/typing/mtype.cmo \
+  $(OTOPDIR)/typing/includecore.cmo \
+  $(OTOPDIR)/typing/includemod.cmo \
+  $(OTOPDIR)/typing/parmatch.cmo \
+  $(OTOPDIR)/typing/typetexp.cmo \
+  $(OTOPDIR)/typing/typedtreeMap.cmo \
+  $(OTOPDIR)/typing/cmt_format.cmo \
+  $(OTOPDIR)/typing/stypes.cmo \
+  $(OTOPDIR)/typing/typecore.cmo \
+  $(OTOPDIR)/typing/typedecl.cmo \
+  $(OTOPDIR)/typing/typeclass.cmo \
+  $(OTOPDIR)/typing/typemod.cmo \
+  $(OTOPDIR)/bytecomp/lambda.cmo \
+  $(OTOPDIR)/bytecomp/printlambda.cmo \
+  $(OTOPDIR)/bytecomp/typeopt.cmo \
+  $(OTOPDIR)/bytecomp/switch.cmo \
+  $(OTOPDIR)/bytecomp/matching.cmo \
+  $(OTOPDIR)/bytecomp/translobj.cmo \
+  $(OTOPDIR)/bytecomp/translcore.cmo \
+  $(OTOPDIR)/bytecomp/translclass.cmo \
+  $(OTOPDIR)/bytecomp/translmod.cmo \
+  $(OTOPDIR)/bytecomp/simplif.cmo \
+  $(OTOPDIR)/bytecomp/runtimedef.cmo \
+  $(OTOPDIR)/asmcomp/arch.cmo \
+  $(OTOPDIR)/asmcomp/debuginfo.cmo \
+  $(OTOPDIR)/asmcomp/cmm.cmo \
+  $(OTOPDIR)/asmcomp/printcmm.cmo \
+  $(OTOPDIR)/asmcomp/reg.cmo \
+  $(OTOPDIR)/asmcomp/mach.cmo \
+  $(OTOPDIR)/asmcomp/proc.cmo \
+  $(OTOPDIR)/asmcomp/clambda.cmo \
+  $(OTOPDIR)/asmcomp/compilenv.cmo \
+  $(OTOPDIR)/asmcomp/closure.cmo \
+  $(OTOPDIR)/asmcomp/cmmgen.cmo \
+  $(OTOPDIR)/asmcomp/printmach.cmo \
+  $(OTOPDIR)/asmcomp/selectgen.cmo \
+  $(OTOPDIR)/asmcomp/selection.cmo \
+  $(OTOPDIR)/asmcomp/comballoc.cmo \
+  $(OTOPDIR)/asmcomp/liveness.cmo \
+  $(OTOPDIR)/asmcomp/spill.cmo \
+  $(OTOPDIR)/asmcomp/split.cmo \
+  $(OTOPDIR)/asmcomp/interf.cmo \
+  $(OTOPDIR)/asmcomp/coloring.cmo \
+  $(OTOPDIR)/asmcomp/reloadgen.cmo \
+  $(OTOPDIR)/asmcomp/reload.cmo \
+  $(OTOPDIR)/asmcomp/printlinear.cmo \
+  $(OTOPDIR)/asmcomp/linearize.cmo \
+  $(OTOPDIR)/asmcomp/schedgen.cmo \
+  $(OTOPDIR)/asmcomp/scheduling.cmo \
+  $(OTOPDIR)/asmcomp/emitaux.cmo \
+  $(OTOPDIR)/asmcomp/emit.cmo \
+  $(OTOPDIR)/asmcomp/printclambda.cmo \
+  $(OTOPDIR)/asmcomp/asmgen.cmo
 
 OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
 
 ADD_COMPFLAGS=$(INCLUDES) -g
 
 default:
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	@if $(BYTECODE_ONLY) || [ -z "$(ASPP)" ]; then : ; else \
 	  $(MAKE) all; \
 	fi
 
@@ -134,8 +148,8 @@ tests: $(CASES:=.o)
 	done
 
 one:
-	@$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o \
+	&& echo " => passed" || echo " => failed"
 
 clean: defaultclean
 	@rm -f ./codegen *.out
diff --git a/testsuite/tests/asmcomp/alpha.S b/testsuite/tests/asmcomp/alpha.S
index 1caf0c6b..fd5fef1e 100644
--- a/testsuite/tests/asmcomp/alpha.S
+++ b/testsuite/tests/asmcomp/alpha.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: alpha.S 11156 2011-07-27 14:17:02Z doligez $ */
-
         .globl  call_gen_code
         .ent    call_gen_code
 
diff --git a/testsuite/tests/asmcomp/amd64.S b/testsuite/tests/asmcomp/amd64.S
index 7b64db8a..846eab95 100644
--- a/testsuite/tests/asmcomp/amd64.S
+++ b/testsuite/tests/asmcomp/amd64.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: amd64.S 12800 2012-07-30 18:59:07Z doligez $ */
-
 #ifdef SYS_macosx
 #define ALIGN 4
 #else
@@ -60,6 +58,8 @@ CAML_C_CALL:
 
 #ifdef SYS_macosx
         .literal16
+#elif defined(SYS_mingw64)
+        .section        .rodata.cst8
 #else
         .section        .rodata.cst8,"aM",@progbits,8
 #endif
diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm
index fe3b0f84..ac9d02c2 100644
--- a/testsuite/tests/asmcomp/arith.cmm
+++ b/testsuite/tests/asmcomp/arith.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: arith.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Regression test for arithmetic instructions *)
 
 (function "testarith" ()
diff --git a/testsuite/tests/asmcomp/arm.S b/testsuite/tests/asmcomp/arm.S
index f459bd33..2e364564 100644
--- a/testsuite/tests/asmcomp/arm.S
+++ b/testsuite/tests/asmcomp/arm.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: arm.S 12800 2012-07-30 18:59:07Z doligez $ */
-
         .text
 
         .global call_gen_code
diff --git a/testsuite/tests/asmcomp/checkbound.cmm b/testsuite/tests/asmcomp/checkbound.cmm
index 81c72651..1968154b 100644
--- a/testsuite/tests/asmcomp/checkbound.cmm
+++ b/testsuite/tests/asmcomp/checkbound.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: checkbound.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (function "checkbound2" (x: int y: int)
   (checkbound x y))
 
diff --git a/testsuite/tests/asmcomp/fib.cmm b/testsuite/tests/asmcomp/fib.cmm
index fba4e329..db79c673 100644
--- a/testsuite/tests/asmcomp/fib.cmm
+++ b/testsuite/tests/asmcomp/fib.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fib.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "fib" (n: int)
   (if (< n 2)
       1
diff --git a/testsuite/tests/asmcomp/hppa.S b/testsuite/tests/asmcomp/hppa.S
index 2d130ded..5f7455b7 100644
--- a/testsuite/tests/asmcomp/hppa.S
+++ b/testsuite/tests/asmcomp/hppa.S
@@ -10,7 +10,6 @@
 ;*                                                                   *
 ;*********************************************************************
 
-; $Id: hppa.S 12800 2012-07-30 18:59:07Z doligez $
 ; Must be preprocessed by cpp
 
 #ifdef SYS_hpux
diff --git a/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S
index 19041085..cc8a3638 100644
--- a/testsuite/tests/asmcomp/i386.S
+++ b/testsuite/tests/asmcomp/i386.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: i386.S 12649 2012-06-27 12:29:20Z doligez $ */
-
 /* Linux with ELF binaries does not prefix identifiers with _.
    Linux with a.out binaries, FreeBSD, and NextStep do. */
 
diff --git a/testsuite/tests/asmcomp/i386nt.asm b/testsuite/tests/asmcomp/i386nt.asm
index 5a2fc0c8..618d41c9 100644
--- a/testsuite/tests/asmcomp/i386nt.asm
+++ b/testsuite/tests/asmcomp/i386nt.asm
@@ -10,8 +10,6 @@
 ;                                                                     ;
 ;*********************************************************************;
 
-; $Id: i386nt.asm 12800 2012-07-30 18:59:07Z doligez $
-
         .386
         .MODEL FLAT
 
diff --git a/testsuite/tests/asmcomp/ia64.S b/testsuite/tests/asmcomp/ia64.S
index c5a44117..b1aa5e83 100644
--- a/testsuite/tests/asmcomp/ia64.S
+++ b/testsuite/tests/asmcomp/ia64.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: ia64.S 12149 2012-02-10 16:15:24Z doligez $ */
-
 #define ST8OFF(a,b,d) st8 [a] = b, d
 #define LD8OFF(a,b,d) ld8 a = [b], d
 #define STFDOFF(a,b,d) stfd [a] = b, d
diff --git a/testsuite/tests/asmcomp/integr.cmm b/testsuite/tests/asmcomp/integr.cmm
index 771fdc9c..61c707a4 100644
--- a/testsuite/tests/asmcomp/integr.cmm
+++ b/testsuite/tests/asmcomp/integr.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: integr.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "square" (x: float)
    ( *f x x))
 
diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli
index 30a9c9a5..e395abeb 100644
--- a/testsuite/tests/asmcomp/lexcmm.mli
+++ b/testsuite/tests/asmcomp/lexcmm.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexcmm.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 val token: Lexing.lexbuf -> Parsecmm.token
 
 type error =
diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
index 1e007265..78346561 100644
--- a/testsuite/tests/asmcomp/lexcmm.mll
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexcmm.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
 {
 open Parsecmm
 
diff --git a/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S
index 8cfc407f..4d0f6a3a 100644
--- a/testsuite/tests/asmcomp/m68k.S
+++ b/testsuite/tests/asmcomp/m68k.S
@@ -10,8 +10,6 @@
 |*                                                                     *
 |***********************************************************************
 
-| $Id: m68k.S 12800 2012-07-30 18:59:07Z doligez $
-
 | call_gen_code is used with the following types:
 |       unit -> int
 |       int -> int
diff --git a/testsuite/tests/asmcomp/main.c b/testsuite/tests/asmcomp/main.c
index 1a3660e9..0b59b0b8 100644
--- a/testsuite/tests/asmcomp/main.c
+++ b/testsuite/tests/asmcomp/main.c
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: main.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
index b454a030..d67a6436 100644
--- a/testsuite/tests/asmcomp/main.ml
+++ b/testsuite/tests/asmcomp/main.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: main.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Clflags
 
 let compile_file filename =
@@ -21,7 +19,8 @@ let compile_file filename =
   let lb = Lexing.from_channel ic in
   try
     while true do
-      Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb)
+      Asmgen.compile_phrase Format.std_formatter
+                            (Parsecmm.phrase Lexcmm.token lb)
     done
   with
       End_of_file ->
diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c
index 77b13473..f935391b 100644
--- a/testsuite/tests/asmcomp/mainarith.c
+++ b/testsuite/tests/asmcomp/mainarith.c
@@ -10,35 +10,36 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mainarith.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include 
 #include 
 #include 
 #include 
 #include 
 
+#include "../../../byterun/config.h"
+#define FMT ARCH_INTNAT_PRINTF_FORMAT
+
 void caml_ml_array_bound_error(void)
 {
   fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
   exit(2);
 }
 
-long R[200];
+intnat R[200];
 double D[40];
-long X, Y;
+intnat X, Y;
 double F, G;
 
 #define INTTEST(arg,res) \
-  { long result = (res); \
+  { intnat result = (res); \
     if (arg != result) \
-      printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %ld, expected %ld\n", \
+      printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %"FMT"d, expected %"FMT"d\n", \
              #arg, #res, X, Y, arg, result); \
   }
 #define INTFLOATTEST(arg,res) \
-  { long result = (res); \
+  { intnat result = (res); \
     if (arg != result) \
-      printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %ld, expected %ld\n", \
+      printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %"FMT"d, expected %"FMT"d\n", \
              #arg, #res, F, G, arg, result); \
   }
 #define FLOATTEST(arg,res) \
@@ -50,7 +51,7 @@ double F, G;
 #define FLOATINTTEST(arg,res) \
   { double result = (res); \
     if (arg < result || arg > result) \
-      printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %.15g, expected %.15g\n", \
+      printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %.15g, expected %.15g\n", \
              #arg, #res, X, Y, arg, result); \
   }
 
@@ -75,15 +76,15 @@ void do_test(void)
       INTTEST(R[10], (X + 1));
       INTTEST(R[11], (X + -1));
 
-      INTTEST(R[12], ((long) ((char *)R + 8)));
-      INTTEST(R[13], ((long) ((char *)R + Y)));
+      INTTEST(R[12], ((intnat) ((char *)R + 8)));
+      INTTEST(R[13], ((intnat) ((char *)R + Y)));
 
       INTTEST(R[14], (X - Y));
       INTTEST(R[15], (X - 1));
       INTTEST(R[16], (X - -1));
 
-      INTTEST(R[17], ((long) ((char *)R - 8)));
-      INTTEST(R[18], ((long) ((char *)R - Y)));
+      INTTEST(R[17], ((intnat) ((char *)R - 8)));
+      INTTEST(R[18], ((intnat) ((char *)R - Y)));
 
       INTTEST(R[19], (X * 2));
       INTTEST(R[20], (2 * X));
@@ -118,9 +119,9 @@ void do_test(void)
       INTTEST(R[43], (X << 1));
       INTTEST(R[44], (X << 8));
 
-      INTTEST(R[45], ((unsigned long) X >> Y));
-      INTTEST(R[46], ((unsigned long) X >> 1));
-      INTTEST(R[47], ((unsigned long) X >> 8));
+      INTTEST(R[45], ((uintnat) X >> Y));
+      INTTEST(R[46], ((uintnat) X >> 1));
+      INTTEST(R[47], ((uintnat) X >> 8));
 
       INTTEST(R[48], (X >> Y));
       INTTEST(R[49], (X >> 1));
@@ -190,7 +191,7 @@ void do_test(void)
       INTFLOATTEST(R[86], (F >= G));
 
       FLOATINTTEST(D[19], (double) X);
-      INTFLOATTEST(R[87], (long) F);
+      INTFLOATTEST(R[87], (intnat) F);
 
       INTTEST(R[88], (X >= 0) && (X < Y));
       INTTEST(R[89], (0 < Y));
@@ -225,7 +226,7 @@ void do_test(void)
       INTFLOATTEST(R[114], (F + 1.0 >= G));
 
       FLOATINTTEST(D[20], ((double) X) + 1.0);
-      INTFLOATTEST(R[115], (long)(F + 1.0));
+      INTFLOATTEST(R[115], (intnat)(F + 1.0));
 
       FLOATTEST(D[21], F + G);
       FLOATTEST(D[22], G + F);
diff --git a/testsuite/tests/asmcomp/mips.s b/testsuite/tests/asmcomp/mips.s
index 7a9dc3f8..db4f23ea 100644
--- a/testsuite/tests/asmcomp/mips.s
+++ b/testsuite/tests/asmcomp/mips.s
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: mips.s 11156 2011-07-27 14:17:02Z doligez $ */
-
         .globl  call_gen_code
         .ent    call_gen_code
 call_gen_code:
diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
index 666ef86d..c8b03858 100644
--- a/testsuite/tests/asmcomp/parsecmm.mly
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: parsecmm.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
 /* A simple parser for C-- */
 
 %{
diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
index 1895c647..1c0848dd 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.ml
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsecmmaux.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Auxiliary functions for parsing *)
 
 type error =
diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
index f3b72383..0f2e370a 100644
--- a/testsuite/tests/asmcomp/parsecmmaux.mli
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parsecmmaux.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Auxiliary functions for parsing *)
 
 val bind_ident: string -> Ident.t
diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S
index b634f3c0..788c86ff 100644
--- a/testsuite/tests/asmcomp/power-aix.S
+++ b/testsuite/tests/asmcomp/power-aix.S
@@ -10,8 +10,6 @@
 #*                                                                   *
 #*********************************************************************
 
-# $Id: power-aix.S 12149 2012-02-10 16:15:24Z doligez $
-
         .csect  .text[PR]
 
         .globl  .call_gen_code
diff --git a/testsuite/tests/asmcomp/power-elf.S b/testsuite/tests/asmcomp/power-elf.S
index ee5d9207..7ff87c59 100644
--- a/testsuite/tests/asmcomp/power-elf.S
+++ b/testsuite/tests/asmcomp/power-elf.S
@@ -10,8 +10,6 @@
 /*                                                                   */
 /*********************************************************************/
 
-/* $Id: power-elf.S 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* Save and restore all callee-save registers */
 /* GPR 14 at sp+16 ... GPR 31 at sp+84
    FPR 14 at sp+92 ... FPR 31 at sp+228 */
diff --git a/testsuite/tests/asmcomp/power-rhapsody.S b/testsuite/tests/asmcomp/power-rhapsody.S
index 3ad2a72d..be13cc14 100644
--- a/testsuite/tests/asmcomp/power-rhapsody.S
+++ b/testsuite/tests/asmcomp/power-rhapsody.S
@@ -10,8 +10,6 @@
 /*                                                                   */
 /*********************************************************************/
 
-/* $Id: power-rhapsody.S 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* Save and restore all callee-save registers */
 /* GPR 14 at sp+16 ... GPR 31 at sp+84
    FPR 14 at sp+92 ... FPR 31 at sp+228 */
diff --git a/testsuite/tests/asmcomp/quicksort.cmm b/testsuite/tests/asmcomp/quicksort.cmm
index b82c2f99..9681ee87 100644
--- a/testsuite/tests/asmcomp/quicksort.cmm
+++ b/testsuite/tests/asmcomp/quicksort.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: quicksort.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "quicksort" (lo: int hi: int a: addr)
   (if (< lo hi)
       (let (i lo
diff --git a/testsuite/tests/asmcomp/quicksort2.cmm b/testsuite/tests/asmcomp/quicksort2.cmm
index fcea6043..74e2a0c9 100644
--- a/testsuite/tests/asmcomp/quicksort2.cmm
+++ b/testsuite/tests/asmcomp/quicksort2.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: quicksort2.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "cmp" (i: int j: int)
   (- i j))
 
diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
index fb67bde4..dcf8b0b6 100644
--- a/testsuite/tests/asmcomp/soli.cmm
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: soli.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 ("d1": int 0 int 1
  "d2": int 1 int 0
  "d3": int 0 int -1
diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S
index 8f2c8354..53c5fc90 100644
--- a/testsuite/tests/asmcomp/sparc.S
+++ b/testsuite/tests/asmcomp/sparc.S
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: sparc.S 12649 2012-06-27 12:29:20Z doligez $ */
-
 #if defined(SYS_solaris) || defined(SYS_elf)
 #define Call_gen_code _call_gen_code
 #define Caml_c_call _caml_c_call
diff --git a/testsuite/tests/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm
index ece00ec3..945b1a1d 100644
--- a/testsuite/tests/asmcomp/tagged-fib.cmm
+++ b/testsuite/tests/asmcomp/tagged-fib.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tagged-fib.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (function "fib" (n: int)
   (if (< n 5)
       3
diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm
index 1a92e8f9..01519290 100644
--- a/testsuite/tests/asmcomp/tagged-integr.cmm
+++ b/testsuite/tests/asmcomp/tagged-integr.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tagged-integr.cmm 12800 2012-07-30 18:59:07Z doligez $ *)
-
 ("res_square": skip 8)
 ("h": skip 8)
 ("x": skip 8)
diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm
index 3c0fde07..501e3916 100644
--- a/testsuite/tests/asmcomp/tagged-quicksort.cmm
+++ b/testsuite/tests/asmcomp/tagged-quicksort.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tagged-quicksort.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "quick" (lo: int hi: int a: addr)
   (if (< lo hi)
       (let (i lo
diff --git a/testsuite/tests/asmcomp/tagged-tak.cmm b/testsuite/tests/asmcomp/tagged-tak.cmm
index c7c1702e..73e76684 100644
--- a/testsuite/tests/asmcomp/tagged-tak.cmm
+++ b/testsuite/tests/asmcomp/tagged-tak.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tagged-tak.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "tak" (x:int y:int z:int)
   (if (> x y)
       (app "tak" (app "tak" (- x 2) y z int)
diff --git a/testsuite/tests/asmcomp/tak.cmm b/testsuite/tests/asmcomp/tak.cmm
index a2f22490..fe71cb8d 100644
--- a/testsuite/tests/asmcomp/tak.cmm
+++ b/testsuite/tests/asmcomp/tak.cmm
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tak.cmm 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (function "tak" (x:int y:int z:int)
   (if (> x y)
       (app "tak" (app "tak" (- x 1) y z int)
diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
index 0d368bfc..83f94721 100644
--- a/testsuite/tests/backtrace/Makefile
+++ b/testsuite/tests/backtrace/Makefile
@@ -1,19 +1,80 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
-EXECNAME=./program
+EXECNAME=program$(EXE)
+
+ABCDFILES=backtrace.ml
+OTHERFILES=backtrace2.ml raw_backtrace.ml
+
+default:
+	$(MAKE) byte
+	@if $(BYTECODE_ONLY); then : ; else $(MAKE) native; fi
 
-run-all:
-	@for file in *.ml; do \
+.PHONY: byte
+byte:
+	@for file in $(ABCDFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  for arg in a b c d ''; do \
+	    printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \
+	    F="`basename $$file .ml`"; \
+	    (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+	         >$$F.$$arg.byte.result 2>&1; \
+	    $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
+	  done; \
+	done
+	@for file in $(OTHERFILES); do \
+	  rm -f program program.exe; \
 	  $(OCAMLC) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlc:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \
+	       >$$F.byte.result 2>&1; \
+	  $(DIFF) $$F.reference $$F.byte.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
+
+.PHONY: native
+native:
+	@for file in $(ABCDFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
 	  for arg in a b c d ''; do \
-	    printf " ... testing '$$file' (with argument '$$arg'):"; \
-	    OCAMLRUNPARAM=b=1 $(EXECNAME) $$arg > `basename $$file ml`$$arg.result 2>&1; \
-	    $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+	    printf " ... testing '$$file' with ocamlopt and argument '$$arg':"; \
+	    F="`basename $$file .ml`"; \
+	    (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \
+	         >$$F.$$arg.native.result 2>&1; \
+	    $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \
+	    && echo " => passed" || echo " => failed"; \
 	  done; \
 	done
+	@for file in $(OTHERFILES); do \
+	  rm -f program program.exe; \
+	  $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+	  printf " ... testing '$$file' with ocamlc:"; \
+	  F="`basename $$file .ml`"; \
+	  (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \
+	       >$$F.native.result 2>&1; \
+	  $(DIFF) $$F.reference $$F.native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
+	done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.result $(EXECNAME)
+	@rm -f *.result program program.exe
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/backtrace/backtrace..reference b/testsuite/tests/backtrace/backtrace..reference
index dfff0dc6..fdbc70fe 100644
--- a/testsuite/tests/backtrace/backtrace..reference
+++ b/testsuite/tests/backtrace/backtrace..reference
@@ -1,2 +1,2 @@
 Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 17, characters 12-24
+Raised by primitive operation at file "backtrace.ml", line 29, characters 12-24
diff --git a/testsuite/tests/backtrace/backtrace.b.reference b/testsuite/tests/backtrace/backtrace.b.reference
index fb580cf1..a93f65ff 100644
--- a/testsuite/tests/backtrace/backtrace.b.reference
+++ b/testsuite/tests/backtrace/backtrace.b.reference
@@ -1,11 +1,11 @@
 b
 Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 6, characters 21-32
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 10, characters 4-11
-Re-raised at file "backtrace.ml", line 12, characters 68-71
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 18, characters 21-32
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 22, characters 4-11
+Re-raised at file "backtrace.ml", line 24, characters 68-71
+Called from file "backtrace.ml", line 29, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.c.reference b/testsuite/tests/backtrace/backtrace.c.reference
index 84532734..8ca6985f 100644
--- a/testsuite/tests/backtrace/backtrace.c.reference
+++ b/testsuite/tests/backtrace/backtrace.c.reference
@@ -1,3 +1,3 @@
 Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 13, characters 26-37
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 25, characters 26-37
+Called from file "backtrace.ml", line 29, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.d.reference b/testsuite/tests/backtrace/backtrace.d.reference
index 6e8605bf..c4cb390a 100644
--- a/testsuite/tests/backtrace/backtrace.d.reference
+++ b/testsuite/tests/backtrace/backtrace.d.reference
@@ -1,9 +1,9 @@
 Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 6, characters 21-32
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 6, characters 42-53
-Called from file "backtrace.ml", line 10, characters 4-11
-Called from file "backtrace.ml", line 17, characters 9-25
+Raised at file "backtrace.ml", line 18, characters 21-32
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 18, characters 42-53
+Called from file "backtrace.ml", line 22, characters 4-11
+Called from file "backtrace.ml", line 29, characters 9-25
diff --git a/testsuite/tests/backtrace/backtrace.ml b/testsuite/tests/backtrace/backtrace.ml
index d8755710..94fc9476 100644
--- a/testsuite/tests/backtrace/backtrace.ml
+++ b/testsuite/tests/backtrace/backtrace.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A test for stack backtraces *)
 
 exception Error of string
diff --git a/testsuite/tests/backtrace/backtrace2..reference b/testsuite/tests/backtrace/backtrace2..reference
deleted file mode 100644
index 91ede5f3..00000000
--- a/testsuite/tests/backtrace/backtrace2..reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.a.reference b/testsuite/tests/backtrace/backtrace2.a.reference
deleted file mode 100644
index 91ede5f3..00000000
--- a/testsuite/tests/backtrace/backtrace2.a.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.b.reference b/testsuite/tests/backtrace/backtrace2.b.reference
deleted file mode 100644
index 91ede5f3..00000000
--- a/testsuite/tests/backtrace/backtrace2.b.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.c.reference b/testsuite/tests/backtrace/backtrace2.c.reference
deleted file mode 100644
index 91ede5f3..00000000
--- a/testsuite/tests/backtrace/backtrace2.c.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.d.reference b/testsuite/tests/backtrace/backtrace2.d.reference
deleted file mode 100644
index 91ede5f3..00000000
--- a/testsuite/tests/backtrace/backtrace2.d.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Re-raised at file "backtrace2.ml", line 12, characters 68-71
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 13, characters 26-37
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 6, characters 21-32
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 6, characters 42-53
-Called from file "backtrace2.ml", line 10, characters 4-11
-Called from file "backtrace2.ml", line 17, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22
diff --git a/testsuite/tests/backtrace/backtrace2.ml b/testsuite/tests/backtrace/backtrace2.ml
index 1f969b2a..25156165 100644
--- a/testsuite/tests/backtrace/backtrace2.ml
+++ b/testsuite/tests/backtrace/backtrace2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2008 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A test for stack backtraces *)
 
 exception Error of string
diff --git a/testsuite/tests/backtrace/backtrace2.reference b/testsuite/tests/backtrace/backtrace2.reference
new file mode 100644
index 00000000..185c673e
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 18, characters 21-32
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 22, characters 4-11
+Re-raised at file "backtrace2.ml", line 24, characters 68-71
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 25, characters 26-37
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 18, characters 21-32
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 18, characters 42-53
+Called from file "backtrace2.ml", line 22, characters 4-11
+Called from file "backtrace2.ml", line 29, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22
diff --git a/testsuite/tests/backtrace/raw_backtrace.ml b/testsuite/tests/backtrace/raw_backtrace.ml
new file mode 100644
index 00000000..f271f759
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.ml
@@ -0,0 +1,52 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2008 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* A test for stack backtraces *)
+
+exception Error of string
+
+let rec f msg n =
+  if n = 0 then raise(Error msg) else 1 + f msg (n-1)
+
+let g msg =
+  try
+    f msg 5
+  with Error "a" -> print_string "a"; print_newline(); 0
+     | Error "b" as exn -> print_string "b"; print_newline(); raise exn
+     | Error "c" -> raise (Error "c")
+
+let backtrace args =
+  try
+    ignore (g args.(0)); None
+  with exn ->
+    let exn = Printexc.to_string exn in
+    let trace = Printexc.get_raw_backtrace () in
+    Some (exn, trace)
+
+let run args =
+  match backtrace args with
+    | None -> print_string "No exception\n"
+    | Some (exn, trace) ->
+      begin
+        (* raise another exception to stash the global backtrace *)
+        try ignore (f "c" 5); assert false with Error _ -> ();
+      end;
+      Printf.printf "Uncaught exception %s\n" exn;
+      Printexc.print_raw_backtrace stdout trace
+
+let _ =
+  Printexc.record_backtrace true;
+  run [| "a" |];
+  run [| "b" |];
+  run [| "c" |];
+  run [| "d" |];
+  run [| |]
diff --git a/testsuite/tests/backtrace/raw_backtrace.reference b/testsuite/tests/backtrace/raw_backtrace.reference
new file mode 100644
index 00000000..96fb60e8
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 18, characters 21-32
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 22, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 24, characters 68-71
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 25, characters 26-37
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 18, characters 21-32
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 18, characters 42-53
+Called from file "raw_backtrace.ml", line 22, characters 4-11
+Called from file "raw_backtrace.ml", line 29, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 29, characters 14-22
diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
index dbe9b4df..8214dfa2 100644
--- a/testsuite/tests/basic-float/Makefile
+++ b/testsuite/tests/basic-float/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=float_record
 MAIN_MODULE=tfloat_record
diff --git a/testsuite/tests/basic-float/float_record.ml b/testsuite/tests/basic-float/float_record.ml
index 98d5323e..65ef1a65 100644
--- a/testsuite/tests/basic-float/float_record.ml
+++ b/testsuite/tests/basic-float/float_record.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 type t = float;;
 
 let make f = f;;
diff --git a/testsuite/tests/basic-float/float_record.mli b/testsuite/tests/basic-float/float_record.mli
index 4e5970e3..5dfd7a84 100644
--- a/testsuite/tests/basic-float/float_record.mli
+++ b/testsuite/tests/basic-float/float_record.mli
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 type t = private float;;
 
 val make : float -> t;;
diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml
index 996640a0..36fefaf3 100644
--- a/testsuite/tests/basic-float/tfloat_record.ml
+++ b/testsuite/tests/basic-float/tfloat_record.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let s = { Float_record.f = Float_record.make 1.0 };;
 
 print_float (Float_record.from s.Float_record.f);;
diff --git a/testsuite/tests/basic-io-2/Makefile b/testsuite/tests/basic-io-2/Makefile
index a5829bd1..e810916c 100644
--- a/testsuite/tests/basic-io-2/Makefile
+++ b/testsuite/tests/basic-io-2/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=io
diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml
index c457054d..14e458cd 100644
--- a/testsuite/tests/basic-io-2/io.ml
+++ b/testsuite/tests/basic-io-2/io.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test a file copy function *)
 
 let test msg funct f1 f2 =
@@ -93,7 +105,7 @@ let _ =
   test "263-byte chunks" (copy_file 263) src testio;
   test "4011-byte chunks" (copy_file 4011) src testio;
   test "0...8192 byte chunks" (copy_random 8192) src testio;
-  test "line per line, short lines" copy_line "/etc/hosts" testio;
+  test "line per line, short lines" copy_line "test-file-short-lines" testio;
   make_lines lines;
   test "line per line, short and long lines" copy_line lines testio;
   test "backwards, 4096-byte chunks" (copy_seek 4096) src testio;
diff --git a/testsuite/tests/basic-io-2/test-file-short-lines b/testsuite/tests/basic-io-2/test-file-short-lines
new file mode 100644
index 00000000..9c0f7b97
--- /dev/null
+++ b/testsuite/tests/basic-io-2/test-file-short-lines
@@ -0,0 +1,10 @@
+##
+# Host Database
+#
+# localhost is used to configure the loopback interface
+# when the system is booting.  Do not change this entry.
+##
+127.0.0.1	localhost
+255.255.255.255	broadcasthost
+::1             localhost
+fe80::1%lo0	localhost
diff --git a/testsuite/tests/basic-io/Makefile b/testsuite/tests/basic-io/Makefile
index ac99445b..3f9c10ed 100644
--- a/testsuite/tests/basic-io/Makefile
+++ b/testsuite/tests/basic-io/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=wc
diff --git a/testsuite/tests/basic-io/wc.ml b/testsuite/tests/basic-io/wc.ml
index dbe46d9a..d6655a94 100644
--- a/testsuite/tests/basic-io/wc.ml
+++ b/testsuite/tests/basic-io/wc.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Counts characters, lines and words in one or several files. *)
 
 let chars = ref 0
diff --git a/testsuite/tests/basic-io/wc.reference b/testsuite/tests/basic-io/wc.reference
index f7a25047..adaaa750 100644
--- a/testsuite/tests/basic-io/wc.reference
+++ b/testsuite/tests/basic-io/wc.reference
@@ -1 +1 @@
-1198 characters, 178 words, 54 lines
+2013 characters, 233 words, 66 lines
diff --git a/testsuite/tests/basic-manyargs/Makefile b/testsuite/tests/basic-manyargs/Makefile
index d84fc9ba..3cf4a15e 100644
--- a/testsuite/tests/basic-manyargs/Makefile
+++ b/testsuite/tests/basic-manyargs/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=manyargs
diff --git a/testsuite/tests/basic-manyargs/manyargs.ml b/testsuite/tests/basic-manyargs/manyargs.ml
index 70c8662c..3defdf20 100644
--- a/testsuite/tests/basic-manyargs/manyargs.ml
+++ b/testsuite/tests/basic-manyargs/manyargs.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let manyargs a b c d e f g h i j k l m n o =
   print_string "a = "; print_int a; print_newline();
   print_string "b = "; print_int b; print_newline();
@@ -35,7 +47,10 @@ let _ =
   manyargs_tail2 0 1;
   manyargs_tail3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
 
-external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs"
+external manyargs_ext:
+  int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int ->
+    int
+  = "manyargs_argv" "manyargs"
 
 let _ =
   print_string "external:\n"; flush stdout;
diff --git a/testsuite/tests/basic-manyargs/manyargsprim.c b/testsuite/tests/basic-manyargs/manyargsprim.c
index fb715c6b..65e9cf5e 100644
--- a/testsuite/tests/basic-manyargs/manyargsprim.c
+++ b/testsuite/tests/basic-manyargs/manyargsprim.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1995 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.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include "mlvalues.h"
 #include "stdio.h"
 
diff --git a/testsuite/tests/basic-more/Makefile b/testsuite/tests/basic-more/Makefile
index 329d67de..9805d2db 100644
--- a/testsuite/tests/basic-more/Makefile
+++ b/testsuite/tests/basic-more/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=testing
 
diff --git a/testsuite/tests/basic-more/bounds.ml b/testsuite/tests/basic-more/bounds.ml
index edaa0c8a..0b30d834 100644
--- a/testsuite/tests/basic-more/bounds.ml
+++ b/testsuite/tests/basic-more/bounds.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test bound checks with ocamlopt *)
 
 let a = [| 0; 1; 2 |]
diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml
index 05bfea5e..eaf604e8 100644
--- a/testsuite/tests/basic-more/morematch.ml
+++ b/testsuite/tests/basic-more/morematch.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (**************************************************************)
 (*  This suite tests the pattern-matching compiler            *)
 (*  it should just compile and run.                           *)
diff --git a/testsuite/tests/basic-more/tbuffer.ml b/testsuite/tests/basic-more/tbuffer.ml
index b8348575..75f49dd1 100644
--- a/testsuite/tests/basic-more/tbuffer.ml
+++ b/testsuite/tests/basic-more/tbuffer.ml
@@ -1,3 +1,15 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                 OCaml                                 *)
+(*                                                                       *)
+(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
+(*                                                                       *)
+(*   Copyright 2009 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.                *)
+(*                                                                       *)
+(*************************************************************************)
+
 (* Dummy substitute function. *)
 
 open Testing;;
diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
index 8a7ab475..76acd4c2 100644
--- a/testsuite/tests/basic-more/testrandom.ml
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Random
 
 let _ =
diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
index 1b129dfb..64176d88 100644
--- a/testsuite/tests/basic-more/tformat.ml
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -10,7 +10,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: tformat.ml 11156 2011-07-27 14:17:02Z doligez $
+(*
 
 A testbed file for the module Format.
 
diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml
index 8bbc9f71..9ea9366f 100644
--- a/testsuite/tests/basic-more/tprintf.ml
+++ b/testsuite/tests/basic-more/tprintf.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2006 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Testing;;
 
 open Printf;;
@@ -66,7 +78,7 @@ let test5 () =
   sprintf "%(toto %s titi.\n%).\n"
     "Bonjour %s" "toto" = "Bonjour toto.\n" &&
   sprintf "%(toto %s titi.\n%)%s\n"
-    "Bonjour %s." "toto" " Ça va?" = "Bonjour toto. Ça va?\n"
+    "Bonjour %s." "toto" " Ca va?" = "Bonjour toto. Ca va?\n"
 ;;
 
 test (test5 ());;
diff --git a/testsuite/tests/basic-multdef/Makefile b/testsuite/tests/basic-multdef/Makefile
index 5ec6aff7..1405f305 100644
--- a/testsuite/tests/basic-multdef/Makefile
+++ b/testsuite/tests/basic-multdef/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=multdef
 MAIN_MODULE=usemultdef
diff --git a/testsuite/tests/basic-multdef/multdef.ml b/testsuite/tests/basic-multdef/multdef.ml
index 46869c45..46957d02 100644
--- a/testsuite/tests/basic-multdef/multdef.ml
+++ b/testsuite/tests/basic-multdef/multdef.ml
@@ -1,2 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let f x = x + 1
 external g : string -> int = "caml_int_of_string"
diff --git a/testsuite/tests/basic-multdef/multdef.mli b/testsuite/tests/basic-multdef/multdef.mli
index 8d67a548..0785dfc2 100644
--- a/testsuite/tests/basic-multdef/multdef.mli
+++ b/testsuite/tests/basic-multdef/multdef.mli
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 val f : int -> int
 val f : int -> int
 val g : string -> int
diff --git a/testsuite/tests/basic-multdef/usemultdef.ml b/testsuite/tests/basic-multdef/usemultdef.ml
index 2bccabb6..1b44e7b9 100644
--- a/testsuite/tests/basic-multdef/usemultdef.ml
+++ b/testsuite/tests/basic-multdef/usemultdef.ml
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let _ = print_int(Multdef.f 1); print_newline(); exit 0
diff --git a/testsuite/tests/basic-private/Makefile b/testsuite/tests/basic-private/Makefile
index 06c5591c..bd36ccb7 100644
--- a/testsuite/tests/basic-private/Makefile
+++ b/testsuite/tests/basic-private/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 MODULES=length
diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml
index fcab2635..df055f00 100644
--- a/testsuite/tests/basic-private/length.ml
+++ b/testsuite/tests/basic-private/length.ml
@@ -1,4 +1,16 @@
-(* $Id: length.ml 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(*
 
 A testbed file for private type abbreviation definitions.
 
diff --git a/testsuite/tests/basic-private/length.mli b/testsuite/tests/basic-private/length.mli
index d1ca0f0a..b26b92b0 100644
--- a/testsuite/tests/basic-private/length.mli
+++ b/testsuite/tests/basic-private/length.mli
@@ -1,4 +1,16 @@
-(* $Id: length.mli 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(*
 
 A testbed file for private type abbreviation definitions.
 
diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml
index 9fd5c90b..3beea60b 100644
--- a/testsuite/tests/basic-private/tlength.ml
+++ b/testsuite/tests/basic-private/tlength.ml
@@ -1,4 +1,16 @@
-(* $Id: tlength.ml 11123 2011-07-20 09:17:07Z doligez $
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(*
 
 A testbed file for private type abbreviation definitions.
 
diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index 4ba0bffc..299656b2 100644
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml
index a25e4ccd..e123edff 100644
--- a/testsuite/tests/basic/arrays.ml
+++ b/testsuite/tests/basic/arrays.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let bigarray n = [|
 n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
 n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;
@@ -90,7 +102,8 @@ let test4 () =
 let test5 () =
   if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then
     print_string "Test5: failed on int arrays\n";
-  if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then
+  if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |]
+  then
     print_string "Test5: failed on float arrays\n"
 
 let test6 () =
diff --git a/testsuite/tests/basic/bigints.ml b/testsuite/tests/basic/bigints.ml
index 23e571c3..e7bb8faa 100644
--- a/testsuite/tests/basic/bigints.ml
+++ b/testsuite/tests/basic/bigints.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let _ =
   match Sys.word_size with
   | 32 ->
diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
index a84e65de..bcb0b823 100644
--- a/testsuite/tests/basic/boxedints.ml
+++ b/testsuite/tests/basic/boxedints.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test the types nativeint, int32, int64 *)
 
 open Printf
@@ -553,7 +565,7 @@ let _ =
   test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0"))
          (Int32.of_string "0x9ABCDEF0")
   else
-  test 3 0 0; (* placeholder to have the same output on both 32-bit and 64-bit *)
+  test 3 0 0; (* placeholder to have the same output on 32-bit and 64-bit *)
   testing_function "int64 of/to int32";
   test 1 (Int64.of_int32 (Int32.of_string "-0x12345678"))
          (Int64.of_string "-0x12345678");
diff --git a/testsuite/tests/basic/equality.ml b/testsuite/tests/basic/equality.ml
index ebf5cf43..ad72e5d0 100644
--- a/testsuite/tests/basic/equality.ml
+++ b/testsuite/tests/basic/equality.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let test n check res =
   print_string "Test "; print_int n;
   if check res then print_string " passed.\n" else print_string " FAILED.\n";
diff --git a/testsuite/tests/basic/float.ml b/testsuite/tests/basic/float.ml
index 9ebabbc4..e10059e2 100644
--- a/testsuite/tests/basic/float.ml
+++ b/testsuite/tests/basic/float.ml
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Moscova, INRIA Rocqencourt          *)
+(*                                                                     *)
+(*  Copyright 2002 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;
diff --git a/testsuite/tests/basic/includestruct.ml b/testsuite/tests/basic/includestruct.ml
index 15708bf9..ae683810 100644
--- a/testsuite/tests/basic/includestruct.ml
+++ b/testsuite/tests/basic/includestruct.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test for "include " inside structures *)
 
 module A =
diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index deb86c43..199f6fe4 100644
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: maps.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
 
 let m1 = IntMap.add 4 "Y" (IntMap.singleton 3 "X1")
diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml
index 64e56174..8f522a9c 100644
--- a/testsuite/tests/basic/patmatch.ml
+++ b/testsuite/tests/basic/patmatch.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Tests for matchings on integers and characters *)
 
 (* Dense integer switch *)
@@ -101,5 +113,19 @@ let _ =
   printf "l([||]) = %d\n" (l [||]);
   printf "l([|1|]) = %d\n" (l [|1|]);
   printf "l([|2;3|]) = %d\n" (l [|2;3|]);
-  printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]);
-  exit 0
+  printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|])
+
+(* PR #5992 *)
+(* Was segfaulting *)
+
+let f = function
+ | lazy (), _, {contents=None} -> 0
+ | _, lazy (), {contents=Some x} -> 1
+
+let s = ref None
+let set_true = lazy (s := Some 1)
+let set_false = lazy (s := None)
+
+let () =
+  let _r = try f (set_true, set_false, s) with Match_failure _ -> 2 in
+  printf "PR#5992=Ok\n"
diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference
index 125c466f..3cae3a36 100644
--- a/testsuite/tests/basic/patmatch.reference
+++ b/testsuite/tests/basic/patmatch.reference
@@ -66,3 +66,4 @@ l([||]) = 0
 l([|1|]) = 2
 l([|2;3|]) = 5
 l([|4;5;6|]) = 15
+PR#5992=Ok
diff --git a/testsuite/tests/basic/recvalues.ml b/testsuite/tests/basic/recvalues.ml
index df32f5e7..4893b105 100644
--- a/testsuite/tests/basic/recvalues.ml
+++ b/testsuite/tests/basic/recvalues.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Recursive value definitions *)
 
 let _ =
diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
index 918f1ac6..d5eb3b71 100644
--- a/testsuite/tests/basic/sets.ml
+++ b/testsuite/tests/basic/sets.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sets.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
 
 let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty
diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml
index 7e37ea71..666acb45 100644
--- a/testsuite/tests/basic/tailcalls.ml
+++ b/testsuite/tests/basic/tailcalls.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rec tailcall4 a b c d =
   if a < 0
   then b
diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
index 0db946a1..26d02ea8 100644
--- a/testsuite/tests/callback/Makefile
+++ b/testsuite/tests/callback/Makefile
@@ -1,32 +1,57 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
-CC=$(NATIVECC) -I $(TOPDIR)/byterun
+CC=$(NATIVECC) -I $(CTOPDIR)/byterun
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix
+LD_PATH=$(TOPDIR)/otherlibs/unix
 
-default: run-byte run-opt
+.PHONY: default
+default:
+	@case " $(OTHERLIBRARIES) " in \
+	  *' unix '*) $(SET_LD_PATH) $(MAKE) run-byte run-opt;; \
+	esac
 
+.PHONY: common
 common:
 	@$(CC) -c callbackprim.c
 
+.PHONY: run-byte
 run-byte: common
 	@printf " ... testing 'bytecode':"
-	@$(OCAMLC) -c tcallback.ml
-	@$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo
-	@./program > bytecode.result
-	@$(DIFF) reference bytecode.result || (echo " => failed" && exit 1)
-	@echo " => passed"
-
+	@$(OCAMLC) $(COMPFLAGS) -c tcallback.ml
+	@$(OCAMLC) $(COMPFLAGS) -o ./program -custom unix.cma \
+	           callbackprim.$(O) tcallback.cmo
+	@./program >bytecode.result
+	@$(DIFF) reference bytecode.result \
+	&& echo " => passed" || echo " => failed"
+
+.PHONY: run-opt
 run-opt: common
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	@if $(BYTECODE_ONLY); then : ; else \
 	  printf " ... testing 'native':"; \
-	  $(OCAMLOPT) -c tcallback.ml; \
-	  $(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx; \
-	  ./program > native.result; \
-	  $(DIFF) reference native.result || (echo " => failed" && exit 1); \
-	  echo " => passed"; \
+	  $(OCAMLOPT) $(COMPFLAGS) -c tcallback.ml; \
+	  $(OCAMLOPT) $(COMPFLAGS) -o ./program unix.cmxa callbackprim.$(O) \
+	              tcallback.cmx; \
+	  ./program >native.result; \
+	  $(DIFF) reference native.result \
+	  && echo " => passed" || echo " => failed"; \
 	fi
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
 	@rm -f *.result ./program
 
diff --git a/testsuite/tests/callback/callbackprim.c b/testsuite/tests/callback/callbackprim.c
index f1a4ccfa..f3c59811 100644
--- a/testsuite/tests/callback/callbackprim.c
+++ b/testsuite/tests/callback/callbackprim.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1995 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.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include "mlvalues.h"
 #include "memory.h"
 #include "callback.h"
diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml
index e0f66fe5..69cae5c2 100644
--- a/testsuite/tests/callback/tcallback.ml
+++ b/testsuite/tests/callback/tcallback.ml
@@ -1,7 +1,21 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1995 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
 external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
-external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3"
-external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
+external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd
+    = "mycallback3"
+external mycallback4 :
+    ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
 
 let rec tak (x, y, z as _tuple) =
   if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
diff --git a/testsuite/tests/embedded/.ignore b/testsuite/tests/embedded/.ignore
new file mode 100644
index 00000000..97d78c3d
--- /dev/null
+++ b/testsuite/tests/embedded/.ignore
@@ -0,0 +1 @@
+caml
diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile
index ec2308dd..2a01c208 100644
--- a/testsuite/tests/embedded/Makefile
+++ b/testsuite/tests/embedded/Makefile
@@ -1,22 +1,44 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
+.PHONY: default
 default: compile run
 
-compile:
-	@$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmstub.c
-	@$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmmain.c
+.PHONY: compile
+compile: caml
+	@$(OCAMLC) -ccopt -I -ccopt . cmstub.c
+	@$(OCAMLC) -ccopt -I -ccopt . cmmain.c
 	@$(OCAMLC) -c cmcaml.ml
-	@$(OCAMLC) -custom -o program cmstub.o cmcaml.cmo cmmain.o
+	@$(OCAMLC) -custom -o program cmstub.$(O) cmcaml.cmo cmmain.$(O)
+
+caml:
+	@mkdir -p caml || :
+	@cp -f $(TOPDIR)/byterun/*.h caml/
 
+.PHONY: run
 run:
 	@printf " ... testing 'cmmain':"
-	@./program > program.result
-	@$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@./program >program.result
+	@$(DIFF) program.reference program.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.result ./program
+	@rm -f *.result program
+	@rm -rf caml
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
index 65c7a610..121cec36 100644
--- a/testsuite/tests/embedded/cmcaml.ml
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* OCaml part of the code *)
 
 let rec fib n =
diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c
index 6c27fe1e..04ed0728 100644
--- a/testsuite/tests/embedded/cmmain.c
+++ b/testsuite/tests/embedded/cmmain.c
@@ -1,3 +1,16 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
 /* Main program -- in C */
 
 #include 
diff --git a/testsuite/tests/embedded/cmstub.c b/testsuite/tests/embedded/cmstub.c
index 56cd6944..4eea82a6 100644
--- a/testsuite/tests/embedded/cmstub.c
+++ b/testsuite/tests/embedded/cmstub.c
@@ -1,3 +1,16 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
 #include 
 #include 
 #include 
diff --git a/testsuite/tests/exotic-syntax/Makefile b/testsuite/tests/exotic-syntax/Makefile
new file mode 100644
index 00000000..38acec51
--- /dev/null
+++ b/testsuite/tests/exotic-syntax/Makefile
@@ -0,0 +1,17 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+MAIN_MODULE=exotic
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/exotic-syntax/exotic.ml b/testsuite/tests/exotic-syntax/exotic.ml
new file mode 100644
index 00000000..873bf339
--- /dev/null
+++ b/testsuite/tests/exotic-syntax/exotic.ml
@@ -0,0 +1,157 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* Exotic OCaml syntax constructs found in the manual that are not *)
+(* used in the source of the OCaml distribution (even in the tests). *)
+
+(* Spaces between the parts of the ?label: token in a typexpr.
+   (used in bin-prot) *)
+type t1 = ? label : int -> int -> int;;
+
+(* Lazy in a pattern. (used in advi) *)
+function lazy y -> y;;
+
+(* Spaces between the parts of the ?label: token in a class-type. *)
+class c1 =
+  (fun ?label:x y -> object end : ? label : int -> int -> object end)
+;;
+
+(* type-class annotation in class-expr *)
+class c2 = (object end : object end);;
+
+(* virtual object field *)
+class virtual c3 = object val virtual x : int end;;
+class virtual c4 = object val mutable virtual x : int end;;
+
+(* abstract module type in a signature *)
+module type T = sig
+  module type U
+end;;
+
+(* associativity rules for patterns *)
+function Some Some x -> x | _ -> 0;;
+function Some `Tag x -> x | _ -> 0;;
+function `Tag Some x -> x | _ -> 0;;
+function `Tag `Tag x -> x | _ -> 0;;
+
+(* negative int32, int64, nativeint constants in patterns *)
+function -1l -> () | _ -> ();;
+function -1L -> () | _ -> ();;
+function -1n -> () | _ -> ();;
+
+(* surprising places where you can use an operator as a variable name *)
+function (+) -> (+);;
+function _ as (+) -> (+);;
+for (+) = 0 to 1 do () done;;
+
+(* access a class-type through an extended-module-path *)
+module F (X : sig end) = struct
+  class type t = object end
+end;;
+module M1 = struct end;;
+class type u = F(M1).t;;
+
+(* conjunctive constraints on tags (used by the compiler to print some
+   inferred types) *)
+type 'a t2 = [< `A of int & int & int ] as 'a;;
+
+(* same for a parameterless tag (triggers a very strange error message) *)
+(*type ('a, 'b) t3 = [< `A of & 'b ] as 'a;;*)
+
+(* negative float constant in a pattern *)
+function -1.0 -> 1 | _ -> 2;;
+
+(* combining language extensions (sec. 7.13 and 7.17) *)
+class c5 = object method f = 1 end;;
+object
+  inherit c5
+  method! f : type t . int = 2
+end;;
+
+(* private polymorphic method with local type *)
+object method private f : type t . int = 1 end;;
+
+
+(* More exotic: not even found in the manual (up to version 4.00),
+   but used in some programs found in the wild.
+*)
+
+(* local functor *)
+let module M (M1 : sig end) = struct end in ();;
+
+(* let-binding with a type coercion *)
+let x :> int = 1;;
+let x : int :> int = 1;;
+
+(* "begin end" as an alias for "()" *)
+begin end;;
+
+(* putting "virtual" before "mutable" or "private" *)
+class type virtual ct = object
+  val mutable virtual x : int
+  val virtual mutable y : int
+  method private virtual f : int
+  method virtual private g : int
+end;;
+class virtual c = object
+  val mutable virtual x : int
+  val virtual mutable y : int
+  method private virtual f : int
+  method virtual private g : int
+end;;
+
+(* Double-semicolon at the beginning of a module body [ocp-indent] *)
+module M2 = struct ;; end;;
+
+
+(**********************
+
+(* Most exotic: not found in the manual (up to 4.00) and not used
+   deliberately by anyone, but still implemented by the compiler. *)
+
+(* whitespace inside val!, method!, inherit! [found in ocamlspot] *)
+object
+  val x = 1
+  val ! x = 2
+  method m = 1
+  method ! m = 2
+  inherit ! object val x = 3 end
+end;;
+
+(* Using () as a constructor name [found in gettext] *)
+type t = ();;
+let x : t = ();;
+
+(* Using :: as a constructor name *)
+type t = :: of int * int;;
+
+(* Prefix syntax for :: in expressions *)
+(::) (1, 1);;
+
+(* Prefix syntax for :: in patterns *)
+function (::) (_, _) -> 1;;
+
+(* Unary plus in expressions (ints and float) *)
++1;;
++1l;;
++1L;;
++1n;;
++1.0;;
+
+(* Unary plus in patterns (ints and floats) *)
+function +1 -> ();;
+function +1l -> ();;
+function +1L -> ();;
+function +1n -> ();;
+function +1.0 -> ();;
+
+**********************)
diff --git a/testsuite/tests/exotic-syntax/exotic.reference b/testsuite/tests/exotic-syntax/exotic.reference
new file mode 100644
index 00000000..e69de29b
diff --git a/testsuite/tests/gc-roots/Makefile b/testsuite/tests/gc-roots/Makefile
index acaf918f..a1089538 100644
--- a/testsuite/tests/gc-roots/Makefile
+++ b/testsuite/tests/gc-roots/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=globroots
diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml
index 6d1948d7..029bc900 100644
--- a/testsuite/tests/gc-roots/globroots.ml
+++ b/testsuite/tests/gc-roots/globroots.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 module type GLOBREF = sig
   type t
   val register: string -> t
diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c
index 32a61a7c..9a1cc843 100644
--- a/testsuite/tests/gc-roots/globrootsprim.c
+++ b/testsuite/tests/gc-roots/globrootsprim.c
@@ -1,3 +1,16 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
 /* For testing global root registration */
 
 #include "mlvalues.h"
@@ -15,7 +28,7 @@ value gb_get(value vblock)
 
 value gb_classic_register(value v)
 {
-  struct block * b = stat_alloc(sizeof(struct block));
+  struct block * b = caml_stat_alloc(sizeof(struct block));
   b->v = v;
   caml_register_global_root(&(b->v));
   return (value) b;
@@ -35,7 +48,7 @@ value gb_classic_remove(value vblock)
 
 value gb_generational_register(value v)
 {
-  struct block * b = stat_alloc(sizeof(struct block));
+  struct block * b = caml_stat_alloc(sizeof(struct block));
   b->v = v;
   caml_register_generational_global_root(&(b->v));
   return (value) b;
diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile
index bcc2fdb0..6e8d01ff 100644
--- a/testsuite/tests/letrec/Makefile
+++ b/testsuite/tests/letrec/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 include $(BASEDIR)/makefiles/Makefile.several
diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
index 4a893225..2fdf14ea 100644
--- a/testsuite/tests/letrec/backreferences.ml
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* testing backreferences; some compilation scheme may handle
    differently recursive references to a mutually-recursive RHS
    depending on whether it is before or after in the bindings list *)
diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
index a7d03388..93bcc807 100644
--- a/testsuite/tests/letrec/class_1.ml
+++ b/testsuite/tests/letrec/class_1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* class expression are compiled to recursive bindings *)
 class test =
 object
diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
index 71c7880d..19d03a43 100644
--- a/testsuite/tests/letrec/class_2.ml
+++ b/testsuite/tests/letrec/class_2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* class expressions may also contain local recursive bindings *)
 class test =
   let rec f = print_endline "f"; fun x -> g x
diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
index 5b88844d..2cd5ac56 100644
--- a/testsuite/tests/letrec/evaluation_order_1.ml
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* test evaluation order
 
    'y' is translated into a constant, and is therefore considered
diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
index 736f82ad..54a8b129 100644
--- a/testsuite/tests/letrec/evaluation_order_2.ml
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A variant of evaluation_order_1.ml where the side-effects
    are inside the blocks. Note that this changes the evaluation
    order, as y is considered recursive.
diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
index 8f76a8f8..5efaf1af 100644
--- a/testsuite/tests/letrec/evaluation_order_3.ml
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 type t = { x : t; y : t }
 
 let p = print_endline
diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
index cdfa9d2f..34f31431 100644
--- a/testsuite/tests/letrec/float_block_1.ml
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* a bug in cmmgen.ml provokes a change in compilation order between
    ocamlc and ocamlopt in certain letrec-bindings involving float
    arrays *)
diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
index 968cba4e..ad8ec61f 100644
--- a/testsuite/tests/letrec/float_block_2.ml
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* a bug in cmmgen.ml provokes a segfault in certain natively compiled
    letrec-bindings involving float arrays *)
 let test =
diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
index 5686e493..f9dec615 100644
--- a/testsuite/tests/letrec/lists.ml
+++ b/testsuite/tests/letrec/lists.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* a test with lists, because cyclic lists are fun *)
 let test =
   let rec li = 0::1::2::3::4::5::6::7::8::9::li in
diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
index e79f79ec..6e274346 100644
--- a/testsuite/tests/letrec/mixing_value_closures_1.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* mixing values and closures may exercise interesting code paths *)
 type t = A of (int -> int)
 let test =
diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
index eb5fcb74..8a684def 100644
--- a/testsuite/tests/letrec/mixing_value_closures_2.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* a polymorphic variant of test3.ml; found a real bug once *)
 let test =
   let rec x = `A f
diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
index a5b6c51f..875758b3 100644
--- a/testsuite/tests/letrec/mutual_functions.ml
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* a simple test with mutually recursive functions *)
 let test =
   let rec even = function
diff --git a/testsuite/tests/letrec/record_with.ml b/testsuite/tests/letrec/record_with.ml
new file mode 100644
index 00000000..daaa88c4
--- /dev/null
+++ b/testsuite/tests/letrec/record_with.ml
@@ -0,0 +1,37 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+
+(* A regression test for both PR#4141 and PR#5819: when a recursive
+   variable is defined by a { record with ... } expression.
+*)
+
+type t = {
+  self : t;
+  t0 : int;
+  t1 : int;
+  t2 : int;
+  t3 : int;
+  t4 : int;
+};;
+let rec t = {
+  self = t;
+  t0 = 42;
+  t1 = 42;
+  t2 = 42;
+  t3 = 42;
+  t4 = 42;
+};;
+
+let rec self = { t with self=self } in
+Printf.printf "%d\n" self.self.t0
+;;
diff --git a/testsuite/tests/letrec/record_with.reference b/testsuite/tests/letrec/record_with.reference
new file mode 100644
index 00000000..d81cc071
--- /dev/null
+++ b/testsuite/tests/letrec/record_with.reference
@@ -0,0 +1 @@
+42
diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/Makefile
index 678c8c88..373ff944 100644
--- a/testsuite/tests/lib-bigarray-2/Makefile
+++ b/testsuite/tests/lib-bigarray-2/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=unix bigarray
 C_FILES=bigarrfstub
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
index 562cfc8a..c259061e 100644
--- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Bigarray
 open Printf
 
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfstub.c b/testsuite/tests/lib-bigarray-2/bigarrfstub.c
index be142f6a..35408284 100644
--- a/testsuite/tests/lib-bigarray-2/bigarrfstub.c
+++ b/testsuite/tests/lib-bigarray-2/bigarrfstub.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, 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 Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include 
 #include 
 #include 
diff --git a/testsuite/tests/lib-bigarray/Makefile b/testsuite/tests/lib-bigarray/Makefile
index 5bfaa030..31ba474f 100644
--- a/testsuite/tests/lib-bigarray/Makefile
+++ b/testsuite/tests/lib-bigarray/Makefile
@@ -1,5 +1,20 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=unix bigarray
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+              -I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray
 
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
index 9c790a1a..333c1754 100644
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Bigarray
 open Printf
 open Complex
diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
index f9c62500..801553f3 100644
--- a/testsuite/tests/lib-bigarray/fftba.ml
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fftba.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Bigarray
 
 let pi = 3.14159265358979323846
diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml
index e75215cf..27afaf56 100644
--- a/testsuite/tests/lib-bigarray/pr5115.ml
+++ b/testsuite/tests/lib-bigarray/pr5115.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2010 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* PR#5115 - multiple evaluation of bigarray expr *)
 
 open Bigarray
diff --git a/testsuite/tests/lib-digest/Makefile b/testsuite/tests/lib-digest/Makefile
index 0e64db8f..adda2765 100644
--- a/testsuite/tests/lib-digest/Makefile
+++ b/testsuite/tests/lib-digest/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=md5
diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
index 27aebf2a..bf7a9a60 100644
--- a/testsuite/tests/lib-digest/md5.ml
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test int32 arithmetic and optimizations using the MD5 algorithm *)
 
 open Printf
diff --git a/testsuite/tests/lib-dynlink-bytecode/.ignore b/testsuite/tests/lib-dynlink-bytecode/.ignore
index 789e3e05..06b64736 100644
--- a/testsuite/tests/lib-dynlink-bytecode/.ignore
+++ b/testsuite/tests/lib-dynlink-bytecode/.ignore
@@ -3,3 +3,4 @@ static
 custom
 custom.exe
 marshal.data
+caml
diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile
index 089d17a5..74f27b9f 100644
--- a/testsuite/tests/lib-dynlink-bytecode/Makefile
+++ b/testsuite/tests/lib-dynlink-bytecode/Makefile
@@ -1,41 +1,71 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
-default: compile run
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH=.:$(TOPDIR)/otherlibs/dynlink
+
+.PHONY: default
+default:
+	@$(SET_LD_PATH) $(MAKE) compile run
 
-compile:
+.PHONY: compile
+compile: caml
 	@$(OCAMLC) -c registry.ml
 	@for file in stub*.c; do \
-	  $(OCAMLC) -c $$file; \
-	  $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' | sed -e 's/\.c//'` `basename $$file c`o; \
+	  $(OCAMLC) -ccopt -I -ccopt . -c $$file; \
+	  $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' -e 's/\.c//'` \
+	                `basename $$file c`$(O); \
 	done
 	@for file in plug*.ml; do \
 	  $(OCAMLC) -c $$file; \
 	  $(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \
 	done
 	@$(OCAMLC) -c main.ml
+	@rm -f main static custom custom.exe
 	@$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo
-	@$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun
-	@$(OCAMLC) -o custom -custom -linkall registry.cmo plug2.cma plug1.cma -I .
+	@$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma \
+	           -use-runtime $(OTOPDIR)/boot/ocamlrun$(EXE)
+	@$(OCAMLC) -o custom$(EXE) -custom -linkall registry.cmo plug2.cma \
+	           plug1.cma -I .
+
+caml:
+	@mkdir -p caml || :
+	@cp -f $(TOPDIR)/byterun/*.h caml/
 
+.PHONY: run
 run:
 	@printf " ... testing 'main'"
-	@export LD_LIBRARY_PATH=`pwd` && ./main plug1.cma plug2.cma > main.result
-	@$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@$(OCAMLRUN) ./main plug1.cma plug2.cma >main.result
+	@$(DIFF) main.reference main.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
 
 	@printf " ... testing 'static'"
-	@export LD_LIBRARY_PATH=`pwd` && ./static > static.result
-	@$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@$(OCAMLRUN) ./static >static.result
+	@$(DIFF) static.reference static.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
 
 	@printf " ... testing 'custom'"
-	@export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result
-	@$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@./custom$(EXE) >custom.result
+	@$(DIFF) custom.reference custom.result >/dev/null \
+	&& echo " => passed" || echo " => failed"
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f ./main ./static ./custom *.result marshal.data
+	@rm -f main static custom custom.exe *.result marshal.data
+	@rm -rf caml
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
index 725ee80c..93655335 100644
--- a/testsuite/tests/lib-dynlink-bytecode/main.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let f x = print_string "This is Main.f\n"; x
 
 let () = Registry.register f
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
index d0490689..6ff30762 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug1.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external stub1: unit -> string = "stub1"
 
 let f x = print_string "This is Plug1.f\n"; x + 1
diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
index 350374e5..e83275e5 100644
--- a/testsuite/tests/lib-dynlink-bytecode/plug2.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external stub2: unit -> unit = "stub2"
 
 let f x = print_string "This is Plug2.f\n"; x + 2
diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
index e0f76423..46915a1b 100644
--- a/testsuite/tests/lib-dynlink-bytecode/registry.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let functions = ref ([]: (int -> int) list)
 
 let register f =
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c
index dcae562a..f97c66f3 100644
--- a/testsuite/tests/lib-dynlink-bytecode/stub1.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                        Alain Frisch, LexiFi                         */
+/*                                                                     */
+/*  Copyright 2007 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
 #include "caml/alloc.h"
diff --git a/testsuite/tests/lib-dynlink-bytecode/stub2.c b/testsuite/tests/lib-dynlink-bytecode/stub2.c
index 4c6e6e3c..4064a75e 100644
--- a/testsuite/tests/lib-dynlink-bytecode/stub2.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub2.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                        Alain Frisch, LexiFi                         */
+/*                                                                     */
+/*  Copyright 2007 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
 #include "caml/alloc.h"
diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index b2027727..17eeea43 100644
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -1,66 +1,97 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 CSC=csc
 
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray
+LD_PATH=$(TOPDIR)/otherlibs/bigarray
+
+.PHONY: default
 default:
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
-	  $(MAKE) all; \
+	@if $(BYTECODE_ONLY); then : ; else \
+	  $(SET_LD_PATH) $(MAKE) all; \
 	fi
 
+.PHONY: all
 all: prepare bytecode bytecode-dll native native-dll
 
+.PHONY: prepare
 prepare:
 	@$(OCAMLC) -c plugin.ml
 	@$(OCAMLOPT) -o plugin.cmxs -shared plugin.ml
 
+.PHONY: bytecode
 bytecode:
 	@printf " ... testing 'bytecode':"
-	@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
-	  echo " => passed"; \
+	@if [ ! `which $(CSC) >/dev/null 2>&1` ]; then \
+	  echo " => skipped"; \
 	else \
 	  $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
 	  $(CSC) /out:main.exe main.cs; \
 	  ./main.exe > bytecode.result; \
-	  $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) bytecode.reference bytecode.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	fi
 
+.PHONY: bytecode-dll
 bytecode-dll:
 	@printf " ... testing 'bytecode-dll':"
 	@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
-	  echo " => passed"; \
+	  echo " => skipped"; \
 	else \
 	  $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \
-	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../byterun/libcamlrun.$(A)  $(BYTECCLIBS) -v; \
+	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+	           ../../byterun/libcamlrun.$(A)  $(BYTECCLIBS) -v; \
 	  $(CSC) /out:main.exe main.cs; \
-	  ./main.exe > bytecode.result; \
-	  $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  ./main.exe >bytecode.result; \
+	  $(DIFF) bytecode.reference bytecode.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	fi
 
+.PHONY: native
 native:
 	@printf " ... testing 'native':"
 	@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
-	  echo " => passed"; \
+	  echo " => skipped"; \
 	else \
 	  $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
 	  $(CSC) /out:main.exe main.cs; \
 	  ./main.exe > native.result; \
-	  $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) native.reference native.result > /dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	fi
 
+.PHONY: native-dll
 native-dll:
 	@printf " ... testing 'native-dll':"
 	@if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \
-	  echo " => passed"; \
+	  echo " => skipped"; \
 	else \
-	  $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c main.ml; \
-	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../asmrun/libasmrun.lib -v; \
+	  $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \
+	              main.ml; \
+	  $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
+	           ../../asmrun/libasmrun.lib -v; \
 	  $(CSC) /out:main.exe main.cs; \
 	  ./main.exe > native.result; \
-	  $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+	  $(DIFF) native.reference native.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	fi
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.result *.exe *.dll
+	@rm -f *.result *.exe *.dll *.so *.obj *.o
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c
index 13ecd73d..a82eb46f 100755
--- a/testsuite/tests/lib-dynlink-csharp/entry.c
+++ b/testsuite/tests/lib-dynlink-csharp/entry.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                        Alain Frisch, LexiFi                         */
+/*                                                                     */
+/*  Copyright 2007 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include 
 #include 
 #include 
@@ -5,7 +17,23 @@
 #include 
 #include 
 
-__declspec(dllexport) void __stdcall start_caml_engine() {
+#if !defined(OPENSTEP) && (defined(__WIN32__) && !defined(__CYGWIN__))
+#  if defined(_MSC_VER) || defined(__MINGW32__)
+#    define _DLLAPI __declspec(dllexport)
+#  else
+#    define _DLLAPI extern
+#  endif 
+#  if defined(__MINGW32__) || defined(UNDER_CE) 
+#    define _CALLPROC
+#  else
+#    define _CALLPROC __stdcall
+#  endif
+#elif defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__) >= 303
+#  define _DLLAPI __attribute__((visibility("default")))
+#  define _CALLPROC
+#endif /* WIN32 && !CYGWIN */
+
+_DLLAPI void _CALLPROC start_caml_engine() {
   char * argv[2];
   argv[0] = "--";
   argv[1] = NULL;
diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml
index ad461882..079e3deb 100755
--- a/testsuite/tests/lib-dynlink-csharp/main.ml
+++ b/testsuite/tests/lib-dynlink-csharp/main.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let load s =
   Printf.printf "Loading %s\n%!" s;
   try
diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml
index aacf9f21..241e8bb5 100755
--- a/testsuite/tests/lib-dynlink-csharp/plugin.ml
+++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let f x = x.{2}
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/.ignore b/testsuite/tests/lib-dynlink-native/.ignore
index 775ccb41..2dd2c724 100644
--- a/testsuite/tests/lib-dynlink-native/.ignore
+++ b/testsuite/tests/lib-dynlink-native/.ignore
@@ -1,5 +1,7 @@
 mypack.pack.s
+mypack.pack.asm
 result
 main
 main.exe
 marshal.data
+caml
diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile
index 9aac1dbe..80e42212 100644
--- a/testsuite/tests/lib-dynlink-native/Makefile
+++ b/testsuite/tests/lib-dynlink-native/Makefile
@@ -1,55 +1,86 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+	  -I $(OTOPDIR)/otherlibs/systhreads \
+          -I $(OTOPDIR)/otherlibs/dynlink
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/dynlink
 
+.PHONY: default
 default:
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
-	  $(MAKE) all; \
+	@if $(BYTECODE_ONLY); then : ; else \
+	   $(SET_LD_PATH) $(MAKE) all; \
 	fi
 
+.PHONY: all
 all: compile run
 
-PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so plugin_thread.so plugin4_unix.so a.so b.so c.so
+PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so \
+        mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so \
+        plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so \
+        plugin_thread.so plugin4_unix.so a.so b.so c.so
 
 ADD_COMPFLAGS=-thread
 
-compile: $(PLUGINS) main mylib.so
+.PHONY: compile
+compile: $(PLUGINS) main$(EXE) mylib.so
 
+.PHONY: run
 run:
 	@printf " ... testing 'main'"
-	@./main plugin.so plugin2.so plugin_thread.so > result
-	@$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1)
-	@echo " => passed"
+	@./main$(EXE) plugin.so plugin2.so plugin_thread.so > result
+	@$(DIFF) reference result >/dev/null \
+	&& echo " => passed" || echo " => failed"
 
-main: api.cmx main.cmx
-	@$(OCAMLOPT) -thread -o main -linkall unix.cmxa threads.cmxa dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK)
+main$(EXE): api.cmx main.cmx
+	@$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \
+	             dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK)
 
-main_ext: api.cmx main.cmx factorial.$(O)
-	@$(OCAMLOPT) -o main_ext dynlink.cmxa api.cmx main.cmx factorial.$(O)
+main_ext$(EXE): api.cmx main.cmx factorial.$(O)
+	@$(OCAMLOPT) -o main_ext$(EXE) dynlink.cmxa api.cmx main.cmx \
+	             factorial.$(O)
 
 sub/plugin3.cmx: sub/api.cmi sub/api.cmx sub/plugin3.ml
-	@(cd sub; mv api.cmx api.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin3.ml; mv api.cmx.bak api.cmx)
+	@cd sub; \
+	mv api.cmx api.cmx.bak; \
+	$(OCAMLOPT) -c plugin3.ml; \
+	mv api.cmx.bak api.cmx
 
 plugin2.cmx: api.cmx plugin.cmi plugin.cmx
-	@(mv plugin.cmx plugin.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin2.ml; mv plugin.cmx.bak plugin.cmx)
+	@mv plugin.cmx plugin.cmx.bak;
+	@$(OCAMLOPT) -c plugin2.ml
+	@mv plugin.cmx.bak plugin.cmx
 
 sub/api.so: sub/api.cmi sub/api.ml
-	@(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) $(SHARED) api.ml)
+	@cd sub; $(OCAMLOPT) -c $(SHARED) api.ml
 
 sub/api.cmi: sub/api.mli
-	@(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.mli)
+	@cd sub; $(OCAMLOPT) -c api.mli
 
 sub/api.cmx: sub/api.cmi sub/api.ml
-	@(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.ml)
+	@cd sub; $(OCAMLOPT) -c api.ml
 
 plugin.cmx: api.cmx plugin.cmi
 sub/plugin.cmx: api.cmx
 plugin4.cmx: api.cmx
 main.cmx: api.cmx
 plugin_ext.cmx: api.cmx plugin_ext.ml
-	@$(OCAMLOPT) -c $(COMPFLAGS) plugin_ext.ml
+	@$(OCAMLOPT) -c plugin_ext.ml
 
 plugin_ext.so: factorial.$(O) plugin_ext.cmx
-	@$(OCAMLOPT) $(COMPFLAGS) -shared -o plugin_ext.so factorial.$(O) plugin_ext.cmx
+	@$(OCAMLOPT) -shared -o plugin_ext.so factorial.$(O) \
+	             plugin_ext.cmx
 
 plugin4_unix.so: plugin4.cmx
 	@$(OCAMLOPT) -shared -o plugin4_unix.so unix.cmxa plugin4.cmx
@@ -67,15 +98,24 @@ mypack.cmx: packed1.cmx
 mylib.cmxa: plugin.cmx plugin2.cmx
 	@$(OCAMLOPT) $(COMPFLAGS) -a -o mylib.cmxa plugin.cmx plugin2.cmx
 
-factorial.$(O): factorial.c
-	@$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" factorial.c
+factorial.$(O): factorial.c caml
+	@$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" -ccopt -I -ccopt . \
+	             factorial.c
+
+caml:
+	@mkdir -p caml || :
+	@cp $(TOPDIR)/byterun/*.h caml/
 
+.PHONY: promote
 promote:
 	@cp result reference
 
+.PHONY: clean
 clean: defaultclean
 	@rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj
 	@rm -f *.a *.lib
 	@rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj
+	@rm -f marshal.data
+	@rm -rf caml
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-dynlink-native/a.ml b/testsuite/tests/lib-dynlink-native/a.ml
index b7915822..c84f9680 100755
--- a/testsuite/tests/lib-dynlink-native/a.ml
+++ b/testsuite/tests/lib-dynlink-native/a.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let x = ref 0
 let u = Random.int 1000
 
diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
index cd735abe..84150002 100644
--- a/testsuite/tests/lib-dynlink-native/api.ml
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let mods = ref []
 
 let reg_mod name =
diff --git a/testsuite/tests/lib-dynlink-native/b.ml b/testsuite/tests/lib-dynlink-native/b.ml
index afa1bef0..02091da4 100755
--- a/testsuite/tests/lib-dynlink-native/b.ml
+++ b/testsuite/tests/lib-dynlink-native/b.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   print_endline "B is running";
   incr A.x;
diff --git a/testsuite/tests/lib-dynlink-native/bug.ml b/testsuite/tests/lib-dynlink-native/bug.ml
index 31c0f025..8965c928 100644
--- a/testsuite/tests/lib-dynlink-native/bug.ml
+++ b/testsuite/tests/lib-dynlink-native/bug.ml
@@ -1,2 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () = try raise (Invalid_argument "X") with Invalid_argument s ->
   raise (Invalid_argument (s ^ s))
diff --git a/testsuite/tests/lib-dynlink-native/c.ml b/testsuite/tests/lib-dynlink-native/c.ml
index d4de70f4..a9bfc8b6 100755
--- a/testsuite/tests/lib-dynlink-native/c.ml
+++ b/testsuite/tests/lib-dynlink-native/c.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   print_endline "C is running";
   incr A.x;
diff --git a/testsuite/tests/lib-dynlink-native/factorial.c b/testsuite/tests/lib-dynlink-native/factorial.c
index c662333e..941227dd 100644
--- a/testsuite/tests/lib-dynlink-native/factorial.c
+++ b/testsuite/tests/lib-dynlink-native/factorial.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                        Alain Frisch, LexiFi                         */
+/*                                                                     */
+/*  Copyright 2007 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
 #include "caml/alloc.h"
diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
index 8c738aeb..01ed2295 100644
--- a/testsuite/tests/lib-dynlink-native/main.ml
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   Api.add_cb (fun () -> print_endline "Callback from main")
 
diff --git a/testsuite/tests/lib-dynlink-native/pack_client.ml b/testsuite/tests/lib-dynlink-native/pack_client.ml
index 90229885..354d3694 100644
--- a/testsuite/tests/lib-dynlink-native/pack_client.ml
+++ b/testsuite/tests/lib-dynlink-native/pack_client.ml
@@ -1,2 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   print_endline Mypack.Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/packed1.ml b/testsuite/tests/lib-dynlink-native/packed1.ml
index 2ee83633..845a3c24 100644
--- a/testsuite/tests/lib-dynlink-native/packed1.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   Api.reg_mod "Packed1"
 
diff --git a/testsuite/tests/lib-dynlink-native/packed1_client.ml b/testsuite/tests/lib-dynlink-native/packed1_client.ml
index c62534fd..5950b668 100644
--- a/testsuite/tests/lib-dynlink-native/packed1_client.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1_client.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   Api.reg_mod "Packed1_client";
   print_endline Packed1.mykey
diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
index d9b0574f..302ba30a 100644
--- a/testsuite/tests/lib-dynlink-native/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rec f x = ignore ([x]); f x
 
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)
diff --git a/testsuite/tests/lib-dynlink-native/plugin.mli b/testsuite/tests/lib-dynlink-native/plugin.mli
index 3e659d97..5ce837bf 100644
--- a/testsuite/tests/lib-dynlink-native/plugin.mli
+++ b/testsuite/tests/lib-dynlink-native/plugin.mli
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 val facts: int list
diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
index 109c129d..e7e9fb3c 100644
--- a/testsuite/tests/lib-dynlink-native/plugin2.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (*external ex: int -> int = "caml_ex"*)
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin4.ml b/testsuite/tests/lib-dynlink-native/plugin4.ml
index a9f86e60..5d0d33eb 100644
--- a/testsuite/tests/lib-dynlink-native/plugin4.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin4.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   Printf.printf "time = %f\n" (Unix.time ());
   Api.reg_mod "Plugin"
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ext.ml b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
index 9906769f..ea9ec85c 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_ext.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external fact: int -> string = "factorial"
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
index 8c58aa15..49a5fde9 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let f x x x x x x x x x x x x x = ()
 
 let g x = f x x x x x x x x
diff --git a/testsuite/tests/lib-dynlink-native/plugin_ref.ml b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
index 60f12735..df98431b 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_ref.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let x = ref 0
 
 let () =
diff --git a/testsuite/tests/lib-dynlink-native/plugin_simple.ml b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
index dd7d0226..cc87b3b9 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_simple.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let facts = [ (Random.int 4) ]
 
 let () = print_endline "COUCOU"; print_char '\n'
diff --git a/testsuite/tests/lib-dynlink-native/plugin_thread.ml b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
index 6e3d9d48..725d5a10 100644
--- a/testsuite/tests/lib-dynlink-native/plugin_thread.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   Api.reg_mod "Plugin_thread";
   let _t =
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.ml b/testsuite/tests/lib-dynlink-native/sub/api.ml
index 4a60586f..476103ed 100644
--- a/testsuite/tests/lib-dynlink-native/sub/api.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/api.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let f i =
   Printf.printf "Sub/api: f called with %i\n" i;
   i + 1
diff --git a/testsuite/tests/lib-dynlink-native/sub/api.mli b/testsuite/tests/lib-dynlink-native/sub/api.mli
index da5e52f2..c4bb98bb 100644
--- a/testsuite/tests/lib-dynlink-native/sub/api.mli
+++ b/testsuite/tests/lib-dynlink-native/sub/api.mli
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 val f : int -> int
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin.ml b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
index d7faf9c8..fb1039d9 100644
--- a/testsuite/tests/lib-dynlink-native/sub/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)
 
 let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ]
diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
index 82c9e486..e06fc38e 100644
--- a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
@@ -1,2 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let () =
   ignore (Api.f 10)
diff --git a/testsuite/tests/lib-format/Makefile b/testsuite/tests/lib-format/Makefile
new file mode 100644
index 00000000..0b385ca4
--- /dev/null
+++ b/testsuite/tests/lib-format/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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+MAIN_MODULE=tformat
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
+ADD_MODULES=testing
+
+include ../../makefiles/Makefile.one
+include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml
new file mode 100644
index 00000000..a627b47f
--- /dev/null
+++ b/testsuite/tests/lib-format/tformat.ml
@@ -0,0 +1,493 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Pierre Weis, projet Pomdapi, INRIA Rocquencourt               *)
+(*                                                                       *)
+(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+(*
+
+A test file for the Format module.
+
+*)
+
+open Testing;;
+open Format;;
+
+let say s = Printf.printf s;;
+
+try
+
+  say "d/i positive\n%!";
+  test (sprintf "%d/%i" 42 43 = "42/43");
+  test (sprintf "%-4d/%-5i" 42 43 = "42  /43   ");
+  test (sprintf "%04d/%05i" 42 43 = "0042/00043");
+  test (sprintf "%+d/%+i" 42 43 = "+42/+43");
+  test (sprintf "% d/% i" 42 43 = " 42/ 43");
+  test (sprintf "%#d/%#i" 42 43 = "42/43");
+  test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
+  test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");
+
+  say "\nd/i negative\n%!";
+  test (sprintf "%d/%i" (-42) (-43) = "-42/-43");
+  test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43  ");
+  test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043");
+  test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43");
+  test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
+  test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");
+  test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
+  test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");
+
+  say "\nu positive\n%!";
+  test (sprintf "%u" 42 = "42");
+  test (sprintf "%-4u" 42 = "42  ");
+  test (sprintf "%04u" 42 = "0042");
+  test (sprintf "%+u" 42 = "42");
+  test (sprintf "% u" 42 = "42");
+  test (sprintf "%#u" 42 = "42");
+  test (sprintf "%4u" 42 = "  42");
+  test (sprintf "%*u" 4 42 = "  42");
+  test (sprintf "%-0+ #6d" 42 = "+42   ");
+
+  say "\nu negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%u" (-1) = "2147483647");
+  | 64 ->
+     test (sprintf "%u" (-1) = "9223372036854775807");
+  | _ -> test false
+  end;
+
+  say "\nx positive\n%!";
+  test (sprintf "%x" 42 = "2a");
+  test (sprintf "%-4x" 42 = "2a  ");
+  test (sprintf "%04x" 42 = "002a");
+  test (sprintf "%+x" 42 = "2a");
+  test (sprintf "% x" 42 = "2a");
+  test (sprintf "%#x" 42 = "0x2a");
+  test (sprintf "%4x" 42 = "  2a");
+  test (sprintf "%*x" 5 42 = "   2a");
+  test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
+
+  say "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%x" (-42) = "7fffffd6");
+  | 64 ->
+     test (sprintf "%x" (-42) = "7fffffffffffffd6");
+  | _ -> test false
+  end;
+
+  say "\nX positive\n%!";
+  test (sprintf "%X" 42 = "2A");
+  test (sprintf "%-4X" 42 = "2A  ");
+  test (sprintf "%04X" 42 = "002A");
+  test (sprintf "%+X" 42 = "2A");
+  test (sprintf "% X" 42 = "2A");
+  test (sprintf "%#X" 42 = "0X2A");
+  test (sprintf "%4X" 42 = "  2A");
+  test (sprintf "%*X" 5 42 = "   2A");
+  test (sprintf "%-0+ #*X" 5 42 = "0X2A ");
+
+  say "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%X" (-42) = "7FFFFFD6");
+  | 64 ->
+     test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+  | _ -> test false
+  end;
+
+  say "\no positive\n%!";
+  test (sprintf "%o" 42 = "52");
+  test (sprintf "%-4o" 42 = "52  ");
+  test (sprintf "%04o" 42 = "0052");
+  test (sprintf "%+o" 42 = "52");
+  test (sprintf "% o" 42 = "52");
+  test (sprintf "%#o" 42 = "052");
+  test (sprintf "%4o" 42 = "  52");
+  test (sprintf "%*o" 5 42 = "   52");
+  test (sprintf "%-0+ #*o" 5 42 = "052  ");
+
+  say "\no negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%o" (-42) = "17777777726");
+  | 64 ->
+     test (sprintf "%o" (-42) = "777777777777777777726");
+  | _ -> test false
+  end;
+
+  say "\ns\n%!";
+  test (sprintf "%s" "foo" = "foo");
+  test (sprintf "%-5s" "foo" = "foo  ");
+  test (sprintf "%05s" "foo" = "  foo");
+  test (sprintf "%+s" "foo" = "foo");
+  test (sprintf "% s" "foo" = "foo");
+  test (sprintf "%#s" "foo" = "foo");
+  test (sprintf "%5s" "foo" = "  foo");
+  test (sprintf "%1s" "foo" = "foo");
+  test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" 2 "foo" = "foo");
+  test (sprintf "%-0+ #5s" "foo" = "foo  ");
+  test (sprintf "%s@@" "foo" = "foo@");
+  test (sprintf "%s@@inria.fr" "foo" = "foo@inria.fr");
+  test (sprintf "%s@@%s" "foo" "inria.fr" = "foo@inria.fr");
+
+  say "\nS\n%!";
+  test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
+(*  test (sprintf "%-5S" "foo" = "\"foo\"  ");   padding not done *)
+(*  test (sprintf "%05S" "foo" = "  \"foo\"");   padding not done *)
+  test (sprintf "%+S" "foo" = "\"foo\"");
+  test (sprintf "% S" "foo" = "\"foo\"");
+  test (sprintf "%#S" "foo" = "\"foo\"");
+(*  test (sprintf "%5S" "foo" = "  \"foo\"");    padding not done *)
+  test (sprintf "%1S" "foo" = "\"foo\"");
+(*  test (sprintf "%*S" 6 "foo" = "   \"foo\"");  padding not done *)
+  test (sprintf "%*S" 2 "foo" = "\"foo\"");
+(*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
+  test (sprintf "%S@@" "foo" = "\"foo\"@");
+  test (sprintf "%S@@inria.fr" "foo" = "\"foo\"@inria.fr");
+  test (sprintf "%S@@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
+
+  say "\nc\n%!";
+  test (sprintf "%c" 'c' = "c");
+(*  test (sprintf "%-4c" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04c" 'c' = "   c");    padding not done *)
+  test (sprintf "%+c" 'c' = "c");
+  test (sprintf "% c" 'c' = "c");
+  test (sprintf "%#c" 'c' = "c");
+(*  test (sprintf "%4c" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*c" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4c" 'c' = "c   ");  padding not done *)
+
+  say "\nC\n%!";
+  test (sprintf "%C" 'c' = "'c'");
+  test (sprintf "%C" '\'' = "'\\''");
+(*  test (sprintf "%-4C" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04C" 'c' = "   c");    padding not done *)
+  test (sprintf "%+C" 'c' = "'c'");
+  test (sprintf "% C" 'c' = "'c'");
+  test (sprintf "%#C" 'c' = "'c'");
+(*  test (sprintf "%4C" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*C" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4C" 'c' = "c   ");  padding not done *)
+
+  say "\nf\n%!";
+  test (sprintf "%f" (-42.42) = "-42.420000");
+  test (sprintf "%-13f" (-42.42) = "-42.420000   ");
+  test (sprintf "%013f" (-42.42) = "-00042.420000");
+  test (sprintf "%+f" 42.42 = "+42.420000");
+  test (sprintf "% f" 42.42 = " 42.420000");
+  test (sprintf "%#f" 42.42 = "42.420000");
+  test (sprintf "%13f" 42.42 = "    42.420000");
+  test (sprintf "%*f" 12 42.42 = "   42.420000");
+  test (sprintf "%-0+ #12f" 42.42 = "+42.420000  ");
+  test (sprintf "%.3f" (-42.42) = "-42.420");
+  test (sprintf "%-13.3f" (-42.42) = "-42.420      ");
+  test (sprintf "%013.3f" (-42.42) = "-00000042.420");
+  test (sprintf "%+.3f" 42.42 = "+42.420");
+  test (sprintf "% .3f" 42.42 = " 42.420");
+  test (sprintf "%#.3f" 42.42 = "42.420");
+  test (sprintf "%13.3f" 42.42 = "       42.420");
+  test (sprintf "%*.*f" 12 3 42.42 = "      42.420");
+  test (sprintf "%-0+ #12.3f" 42.42 = "+42.420     ");
+
+  (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+     digits for the exponent instead of the two used by Linux and BSD.
+     Check that the two strings are equal, except that there may be an
+     extra zero, and if there is one, there may be a missing space or
+     zero. All in the first string relative to the second. *)
+  let ( =* ) s1 s2 =
+    let ss1 = s1 ^ "$" in
+    let ss2 = s2 ^ "$" in
+    let rec loop i1 i2 extra missing =
+      if i1 = String.length ss1 && i2 = String.length ss2 then begin
+        if extra then true else not missing
+      end else if i1 = String.length ss1 || i2 = String.length ss2 then
+        false
+      else begin
+        match ss1.[i1], ss2.[i2] with
+        | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+        | '0', _ when not extra -> loop (i1+1) i2 true missing
+        | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+        | _, _ -> false
+      end
+    in
+    loop 0 0 false false
+  in
+
+  say "\nF\n%!";
+  test (sprintf "%F" 42.42 = "42.42");
+  test (sprintf "%F" 42.42e42 =* "4.242e+43");
+  test (sprintf "%F" 42.00 = "42.");
+  test (sprintf "%F" 0.042 = "0.042");
+(* no padding, no precision
+  test (sprintf "%.3F" 42.42 = "42.420");
+  test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
+  test (sprintf "%.3F" 42.00 = "42.000");
+  test (sprintf "%.3F" 0.0042 = "0.004");
+*)
+
+  say "\ne\n%!";
+  test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+  test (sprintf "%-15e" (-42.42) =* "-4.242000e+01  ");
+  test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+  test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+  test (sprintf "% e" 42.42 =* " 4.242000e+01");
+  test (sprintf "%#e" 42.42 =* "4.242000e+01");
+  test (sprintf "%15e" 42.42 =* "   4.242000e+01");
+  test (sprintf "%*e" 14 42.42 =* "  4.242000e+01");
+  test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");
+  test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+  test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01     ");
+  test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+  test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+  test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+  test (sprintf "%#.3e" 42.42 =* "4.242e+01");
+  test (sprintf "%15.3e" 42.42 =* "      4.242e+01");
+  test (sprintf "%*.*e" 11 3 42.42 =* "  4.242e+01");
+  test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01    ");
+
+  say "\nE\n%!";
+  test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+  test (sprintf "%-15E" (-42.42) =* "-4.242000E+01  ");
+  test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+  test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+  test (sprintf "% E" 42.42 =* " 4.242000E+01");
+  test (sprintf "%#E" 42.42 =* "4.242000E+01");
+  test (sprintf "%15E" 42.42 =* "   4.242000E+01");
+  test (sprintf "%*E" 14 42.42 =* "  4.242000E+01");
+  test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");
+  test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+  test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01     ");
+  test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+  test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+  test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+  test (sprintf "%#.3E" 42.42 =* "4.242E+01");
+  test (sprintf "%15.3E" 42.42 =* "      4.242E+01");
+  test (sprintf "%*.*E" 11 3 42.42 =* "  4.242E+01");
+  test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01    ");
+
+(* %g gives strange results that correspond to neither %f nor %e
+  say "\ng\n%!";
+  test (sprintf "%g" (-42.42) = "-42.42000");
+  test (sprintf "%-15g" (-42.42) = "-42.42000      ");
+  test (sprintf "%015g" (-42.42) = "-00000042.42000");
+  test (sprintf "%+g" 42.42 = "+42.42000");
+  test (sprintf "% g" 42.42 = " 42.42000");
+  test (sprintf "%#g" 42.42 = "42.42000");
+  test (sprintf "%15g" 42.42 = "       42.42000");
+  test (sprintf "%*g" 14 42.42 = "      42.42000");
+  test (sprintf "%-0+ #14g" 42.42 = "+42.42000     ");
+  test (sprintf "%.3g" (-42.42) = "-42.420");
+*)
+
+(* Same for %G
+  say "\nG\n%!";
+*)
+
+  say "\nB\n%!";
+  test (sprintf "%B" true = "true");
+  test (sprintf "%B" false = "false");
+
+  say "\nld/li positive\n%!";
+  test (sprintf "%ld/%li" 42l 43l = "42/43");
+  test (sprintf "%-4ld/%-5li" 42l 43l = "42  /43   ");
+  test (sprintf "%04ld/%05li" 42l 43l = "0042/00043");
+  test (sprintf "%+ld/%+li" 42l 43l = "+42/+43");
+  test (sprintf "% ld/% li" 42l 43l = " 42/ 43");
+  test (sprintf "%#ld/%#li" 42l 43l = "42/43");
+  test (sprintf "%4ld/%5li" 42l 43l = "  42/   43");
+  test (sprintf "%*ld/%*li" 4 42l 5 43l = "  42/   43");
+  test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43  ");
+
+  say "\nld/li negative\n%!";
+  test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43  ");
+  test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+  test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/  -43");
+  test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/  -43");
+  test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43  ");
+
+  say "\nlu positive\n%!";
+  test (sprintf "%lu" 42l = "42");
+  test (sprintf "%-4lu" 42l = "42  ");
+  test (sprintf "%04lu" 42l = "0042");
+  test (sprintf "%+lu" 42l = "42");
+  test (sprintf "% lu" 42l = "42");
+  test (sprintf "%#lu" 42l = "42");
+  test (sprintf "%4lu" 42l = "  42");
+  test (sprintf "%*lu" 4 42l = "  42");
+  test (sprintf "%-0+ #6ld" 42l = "+42   ");
+
+  say "\nlu negative\n%!";
+  test (sprintf "%lu" (-1l) = "4294967295");
+
+  say "\nlx positive\n%!";
+  test (sprintf "%lx" 42l = "2a");
+  test (sprintf "%-4lx" 42l = "2a  ");
+  test (sprintf "%04lx" 42l = "002a");
+  test (sprintf "%+lx" 42l = "2a");
+  test (sprintf "% lx" 42l = "2a");
+  test (sprintf "%#lx" 42l = "0x2a");
+  test (sprintf "%4lx" 42l = "  2a");
+  test (sprintf "%*lx" 5 42l = "   2a");
+  test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");
+
+  say "\nlx negative\n%!";
+  test (sprintf "%lx" (-42l) = "ffffffd6");
+
+  say "\nlX positive\n%!";
+  test (sprintf "%lX" 42l = "2A");
+  test (sprintf "%-4lX" 42l = "2A  ");
+  test (sprintf "%04lX" 42l = "002A");
+  test (sprintf "%+lX" 42l = "2A");
+  test (sprintf "% lX" 42l = "2A");
+  test (sprintf "%#lX" 42l = "0X2A");
+  test (sprintf "%4lX" 42l = "  2A");
+  test (sprintf "%*lX" 5 42l = "   2A");
+  test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");
+
+  say "\nlx negative\n%!";
+  test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+  say "\nlo positive\n%!";
+  test (sprintf "%lo" 42l = "52");
+  test (sprintf "%-4lo" 42l = "52  ");
+  test (sprintf "%04lo" 42l = "0052");
+  test (sprintf "%+lo" 42l = "52");
+  test (sprintf "% lo" 42l = "52");
+  test (sprintf "%#lo" 42l = "052");
+  test (sprintf "%4lo" 42l = "  52");
+  test (sprintf "%*lo" 5 42l = "   52");
+  test (sprintf "%-0+ #*lo" 5 42l = "052  ");
+
+  say "\nlo negative\n%!";
+  test (sprintf "%lo" (-42l) = "37777777726");
+
+  (* Nativeint not tested: looks like too much work, and anyway it should
+     work like Int32 or Int64. *)
+
+  say "\nLd/Li positive\n%!";
+  test (sprintf "%Ld/%Li" 42L 43L = "42/43");
+  test (sprintf "%-4Ld/%-5Li" 42L 43L = "42  /43   ");
+  test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043");
+  test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");
+  test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");
+  test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");
+  test (sprintf "%4Ld/%5Li" 42L 43L = "  42/   43");
+  test (sprintf "%*Ld/%*Li" 4 42L 5 43L = "  42/   43");
+  test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43  ");
+
+  say "\nLd/Li negative\n%!";
+  test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43  ");
+  test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+  test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/  -43");
+  test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/  -43");
+  test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43  ");
+
+  say "\nLu positive\n%!";
+  test (sprintf "%Lu" 42L = "42");
+  test (sprintf "%-4Lu" 42L = "42  ");
+  test (sprintf "%04Lu" 42L = "0042");
+  test (sprintf "%+Lu" 42L = "42");
+  test (sprintf "% Lu" 42L = "42");
+  test (sprintf "%#Lu" 42L = "42");
+  test (sprintf "%4Lu" 42L = "  42");
+  test (sprintf "%*Lu" 4 42L = "  42");
+  test (sprintf "%-0+ #6Ld" 42L = "+42   ");
+
+  say "\nLu negative\n%!";
+  test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+  say "\nLx positive\n%!";
+  test (sprintf "%Lx" 42L = "2a");
+  test (sprintf "%-4Lx" 42L = "2a  ");
+  test (sprintf "%04Lx" 42L = "002a");
+  test (sprintf "%+Lx" 42L = "2a");
+  test (sprintf "% Lx" 42L = "2a");
+  test (sprintf "%#Lx" 42L = "0x2a");
+  test (sprintf "%4Lx" 42L = "  2a");
+  test (sprintf "%*Lx" 5 42L = "   2a");
+  test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");
+
+  say "\nLx negative\n%!";
+  test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+  say "\nLX positive\n%!";
+  test (sprintf "%LX" 42L = "2A");
+  test (sprintf "%-4LX" 42L = "2A  ");
+  test (sprintf "%04LX" 42L = "002A");
+  test (sprintf "%+LX" 42L = "2A");
+  test (sprintf "% LX" 42L = "2A");
+  test (sprintf "%#LX" 42L = "0X2A");
+  test (sprintf "%4LX" 42L = "  2A");
+  test (sprintf "%*LX" 5 42L = "   2A");
+  test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");
+
+  say "\nLx negative\n%!";
+  test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+  say "\nLo positive\n%!";
+  test (sprintf "%Lo" 42L = "52");
+  test (sprintf "%-4Lo" 42L = "52  ");
+  test (sprintf "%04Lo" 42L = "0052");
+  test (sprintf "%+Lo" 42L = "52");
+  test (sprintf "% Lo" 42L = "52");
+  test (sprintf "%#Lo" 42L = "052");
+  test (sprintf "%4Lo" 42L = "  52");
+  test (sprintf "%*Lo" 5 42L = "   52");
+  test (sprintf "%-0+ #*Lo" 5 42L = "052  ");
+
+  say "\nLo negative\n%!";
+  test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+  say "\na\n%!";
+  let x = ref () in
+  let f () y = if y == x then "ok" else "wrong" in
+  test (sprintf "%a" f x = "ok");
+
+  say "\nt\n%!";
+  let f () = "ok" in
+  test (sprintf "%t" f = "ok");
+
+(* %{ fmt %} prints the signature of [fmt], i.e. a canonical representation
+   of the conversions present in [fmt].
+*)
+  say "\n{...%%}\n%!";
+  let f = format_of_string "%f/%s" in
+  test (sprintf "%{%f%s%}" f = "%f%s");
+
+  say "\n(...%%)\n%!";
+  let f = format_of_string "%d/foo/%s" in
+  test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+  say "\n! %% @ , and constants\n%!";
+  test (sprintf "%!" = "");
+  test (sprintf "%%" = "%");
+  test (sprintf "%@" = "@");
+  test (sprintf "%," = "");
+  test (sprintf "@@" = "@");
+  test (sprintf "@@@@" = "@@");
+  test (sprintf "@@%%" = "@%");
+
+  say "\nend of tests\n%!";
+with e ->
+  say "unexpected exception: %s\n%!" (Printexc.to_string e);
+  test false;
+;;
diff --git a/testsuite/tests/lib-format/tformat.reference b/testsuite/tests/lib-format/tformat.reference
new file mode 100644
index 00000000..387dfb85
--- /dev/null
+++ b/testsuite/tests/lib-format/tformat.reference
@@ -0,0 +1,91 @@
+d/i positive
+ 0 1 2 3 4 5 6 7 8
+d/i negative
+ 9 10 11 12 13 14 15 16 17
+u positive
+ 18 19 20 21 22 23 24 25 26
+u negative
+ 27
+x positive
+ 28 29 30 31 32 33 34 35 36
+x negative
+ 37
+X positive
+ 38 39 40 41 42 43 44 45 46
+x negative
+ 47
+o positive
+ 48 49 50 51 52 53 54 55 56
+o negative
+ 57
+s
+ 58 59 60 61 62 63 64 65 66 67 68 69 70 71
+S
+ 72 73 74 75 76 77 78 79 80
+c
+ 81 82 83 84
+C
+ 85 86 87 88 89
+f
+ 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
+F
+ 108 109 110 111
+e
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
+E
+ 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
+B
+ 148 149
+ld/li positive
+ 150 151 152 153 154 155 156 157 158
+ld/li negative
+ 159 160 161 162 163 164 165 166 167
+lu positive
+ 168 169 170 171 172 173 174 175 176
+lu negative
+ 177
+lx positive
+ 178 179 180 181 182 183 184 185 186
+lx negative
+ 187
+lX positive
+ 188 189 190 191 192 193 194 195 196
+lx negative
+ 197
+lo positive
+ 198 199 200 201 202 203 204 205 206
+lo negative
+ 207
+Ld/Li positive
+ 208 209 210 211 212 213 214 215 216
+Ld/Li negative
+ 217 218 219 220 221 222 223 224 225
+Lu positive
+ 226 227 228 229 230 231 232 233 234
+Lu negative
+ 235
+Lx positive
+ 236 237 238 239 240 241 242 243 244
+Lx negative
+ 245
+LX positive
+ 246 247 248 249 250 251 252 253 254
+Lx negative
+ 255
+Lo positive
+ 256 257 258 259 260 261 262 263 264
+Lo negative
+ 265
+a
+ 266
+t
+ 267
+{...%}
+ 268
+(...%)
+ 269
+! % @ , and constants
+ 270 271 272 273 274 275 276
+end of tests
+
+All tests succeeded.
diff --git a/testsuite/tests/lib-hashtbl/Makefile b/testsuite/tests/lib-hashtbl/Makefile
index 4ba0bffc..299656b2 100644
--- a/testsuite/tests/lib-hashtbl/Makefile
+++ b/testsuite/tests/lib-hashtbl/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml
index 8b8205e7..0ff12757 100644
--- a/testsuite/tests/lib-hashtbl/hfun.ml
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2011 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Testing the hash function Hashtbl.hash *)
 (* What is tested:
      - reproducibility on various platforms, esp. 32/64 bit issues
diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
index f5815696..655191a8 100644
--- a/testsuite/tests/lib-hashtbl/htbl.ml
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2011 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Hashtable operations, using maps as a reference *)
 
 open Printf
diff --git a/testsuite/tests/lib-marshal/Makefile b/testsuite/tests/lib-marshal/Makefile
index 1f78273d..34b67dc8 100644
--- a/testsuite/tests/lib-marshal/Makefile
+++ b/testsuite/tests/lib-marshal/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=intext
diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml
index 80fe5b77..41f24bb6 100644
--- a/testsuite/tests/lib-marshal/intext.ml
+++ b/testsuite/tests/lib-marshal/intext.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test for output_value / input_value *)
 
 let max_data_depth = 500000
@@ -524,6 +536,17 @@ let test_infix () =
   test 606 (even' 142 = true);
   test 607 (even' 142 = even 142)
 
+
+let test_mutual_rec_regression () =
+  (* this regression was reported by Cedric Pasteur in PR#5772 *)
+  let rec test_one q x = x > 3
+  and test_list q = List.for_all (test_one q) q in
+  let g () = () in
+  let f q = if test_list q then g () in
+
+  test 700 (try ignore (Marshal.to_string f [Marshal.Closures]); true
+            with _ -> false)
+
 let main() =
   if Array.length Sys.argv <= 2 then begin
     test_out "intext.data"; test_in "intext.data";
@@ -535,7 +558,8 @@ let main() =
     test_block();
     test_deep();
     test_objects();
-    test_infix ()
+    test_infix ();
+    test_mutual_rec_regression ();
   end else
   if Sys.argv.(1) = "make" then begin
     let n = int_of_string Sys.argv.(2) in
diff --git a/testsuite/tests/lib-marshal/intext.reference b/testsuite/tests/lib-marshal/intext.reference
index 6933ef35..af16fa37 100644
--- a/testsuite/tests/lib-marshal/intext.reference
+++ b/testsuite/tests/lib-marshal/intext.reference
@@ -170,3 +170,4 @@ Test 604 passed.
 Test 605 passed.
 Test 606 passed.
 Test 607 passed.
+Test 700 passed.
diff --git a/testsuite/tests/lib-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c
index fca1fb38..924b896e 100644
--- a/testsuite/tests/lib-marshal/intextaux.c
+++ b/testsuite/tests/lib-marshal/intextaux.c
@@ -1,3 +1,15 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the Q Public License version 1.0.               */
+/*                                                                     */
+/***********************************************************************/
+
 #include 
 #include 
 
diff --git a/testsuite/tests/lib-num-2/Makefile b/testsuite/tests/lib-num-2/Makefile
index 7a307e41..142e5d65 100644
--- a/testsuite/tests/lib-num-2/Makefile
+++ b/testsuite/tests/lib-num-2/Makefile
@@ -1,5 +1,19 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=nums
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/num
+LD_PATH=$(TOPDIR)/otherlibs/num
 PROGRAM_ARGS=1000
 
 include $(BASEDIR)/makefiles/Makefile.several
diff --git a/testsuite/tests/lib-num-2/pi_big_int.ml b/testsuite/tests/lib-num-2/pi_big_int.ml
index 22872ba4..acf9af62 100644
--- a/testsuite/tests/lib-num-2/pi_big_int.ml
+++ b/testsuite/tests/lib-num-2/pi_big_int.ml
@@ -1,3 +1,15 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                 OCaml                                 *)
+(*                                                                       *)
+(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
 (* 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. *)
diff --git a/testsuite/tests/lib-num-2/pi_num.ml b/testsuite/tests/lib-num-2/pi_num.ml
index b3625082..a0651a87 100644
--- a/testsuite/tests/lib-num-2/pi_num.ml
+++ b/testsuite/tests/lib-num-2/pi_num.ml
@@ -1,3 +1,14 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                 OCaml                                 *)
+(*                                                                       *)
+(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
 
 (* Pi digits computed with the sreaming algorithm given on pages 4, 6
    & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
diff --git a/testsuite/tests/lib-num/Makefile b/testsuite/tests/lib-num/Makefile
index 08ebbd97..eaa5df73 100644
--- a/testsuite/tests/lib-num/Makefile
+++ b/testsuite/tests/lib-num/Makefile
@@ -1,8 +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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=test test_nats test_big_ints test_ratios test_nums test_io
 MAIN_MODULE=end_test
-ADD_COMPFLAGS=-w a
 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
index 57e099ed..b22ebd8d 100644
--- a/testsuite/tests/lib-num/end_test.ml
+++ b/testsuite/tests/lib-num/end_test.ml
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 Test.end_tests ();;
diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference
index 8e7ac4b6..741d3bfb 100644
--- a/testsuite/tests/lib-num/end_test.reference
+++ b/testsuite/tests/lib-num/end_test.reference
@@ -82,7 +82,7 @@ shift_right_big_int
 shift_right_towards_zero_big_int
  1... 2...
 extract_big_int
- 1... 2... 3... 4... 5... 6...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
 hashing of big integers
  1... 2... 3... 4... 5... 6...
 create_ratio
diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml
index fce8e363..f3cec77d 100644
--- a/testsuite/tests/lib-num/test.ml
+++ b/testsuite/tests/lib-num/test.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Printf;;
 
 let flush_all () = flush stdout; flush stderr;;
diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
index 9d726206..95e5bb97 100644
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Test;;
 open Nat;;
 open Big_int;;
@@ -920,8 +932,20 @@ 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)) 2048 254,
-   zero_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";;
 
diff --git a/testsuite/tests/lib-num/test_io.ml b/testsuite/tests/lib-num/test_io.ml
index 1df11a5f..c21ad37f 100644
--- a/testsuite/tests/lib-num/test_io.ml
+++ b/testsuite/tests/lib-num/test_io.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Test
 open Nat
 open Big_int
diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml
index 739ed37e..7fc15b51 100644
--- a/testsuite/tests/lib-num/test_nats.ml
+++ b/testsuite/tests/lib-num/test_nats.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Test;;
 open Nat;;
 
diff --git a/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml
index 24b5d264..97aa1564 100644
--- a/testsuite/tests/lib-num/test_nums.ml
+++ b/testsuite/tests/lib-num/test_nums.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Test;;
 open Nat;;
 open Big_int;;
diff --git a/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml
index 8896fb86..568e3bce 100644
--- a/testsuite/tests/lib-num/test_ratios.ml
+++ b/testsuite/tests/lib-num/test_ratios.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Test;;
 open Nat;;
 open Big_int;;
diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile
index 94c40472..a8a29471 100644
--- a/testsuite/tests/lib-printf/Makefile
+++ b/testsuite/tests/lib-printf/Makefile
@@ -1,6 +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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 #MODULES=
 MAIN_MODULE=tprintf
-ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
 ADD_MODULES=testing
 
 include ../../makefiles/Makefile.one
diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
index 1e276228..47313b32 100644
--- a/testsuite/tests/lib-printf/tprintf.ml
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -10,8 +10,6 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *)
-
 (*
 
 A test file for the Printf module.
@@ -176,9 +174,9 @@ try
   test (sprintf "%+C" 'c' = "'c'");
   test (sprintf "% C" 'c' = "'c'");
   test (sprintf "%#C" 'c' = "'c'");
-(*  test (sprintf "%4C" 'c' = "   c");     padding not done *)
-(*  test (sprintf "%*C" 2 'c' = " c");     padding not done *)
-(*  test (sprintf "%-0+ #4C" 'c' = "c   ");  padding not done *)
+(*  test (sprintf "%4C" 'c' = " 'c'");     padding not done *)
+(*  test (sprintf "%*C" 2 'c' = "'c'");     padding not done *)
+(*  test (sprintf "%-0+ #4C" 'c' = "'c' ");  padding not done *)
 
   printf "\nf\n%!";
   test (sprintf "%f" (-42.42) = "-42.420000");
@@ -200,9 +198,33 @@ try
   test (sprintf "%*.*f" 12 3 42.42 = "      42.420");
   test (sprintf "%-0+ #12.3f" 42.42 = "+42.420     ");
 
+  (* Under Windows (mingw and maybe also MSVC), the stdlib uses three
+     digits for the exponent instead of the two used by Linux and BSD.
+     Check that the two strings are equal, except that there may be an
+     extra zero, and if there is one, there may be a missing space or
+     zero. All in the first string relative to the second. *)
+  let ( =* ) s1 s2 =
+    let ss1 = s1 ^ "$" in
+    let ss2 = s2 ^ "$" in
+    let rec loop i1 i2 extra missing =
+      if i1 = String.length ss1 && i2 = String.length ss2 then begin
+        if extra then true else not missing
+      end else if i1 = String.length ss1 || i2 = String.length ss2 then
+        false
+      else begin
+        match ss1.[i1], ss2.[i2] with
+        | x, y when x = y -> loop (i1+1) (i2+1) extra missing
+        | '0', _ when not extra -> loop (i1+1) i2 true missing
+        | _, (' '|'0') when not missing -> loop i1 (i2+1) extra true
+        | _, _ -> false
+      end
+    in
+    loop 0 0 false false
+  in
+
   printf "\nF\n%!";
   test (sprintf "%F" 42.42 = "42.42");
-  test (sprintf "%F" 42.42e42 = "4.242e+43");
+  test (sprintf "%F" 42.42e42 =* "4.242e+43");
   test (sprintf "%F" 42.00 = "42.");
   test (sprintf "%F" 0.042 = "0.042");
 (* no padding, no precision
@@ -213,44 +235,44 @@ try
 *)
 
   printf "\ne\n%!";
-  test (sprintf "%e" (-42.42) = "-4.242000e+01");
-  test (sprintf "%-15e" (-42.42) = "-4.242000e+01  ");
-  test (sprintf "%015e" (-42.42) = "-004.242000e+01");
-  test (sprintf "%+e" 42.42 = "+4.242000e+01");
-  test (sprintf "% e" 42.42 = " 4.242000e+01");
-  test (sprintf "%#e" 42.42 = "4.242000e+01");
-  test (sprintf "%15e" 42.42 = "   4.242000e+01");
-  test (sprintf "%*e" 14 42.42 = "  4.242000e+01");
-  test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 ");
-  test (sprintf "%.3e" (-42.42) = "-4.242e+01");
-  test (sprintf "%-15.3e" (-42.42) = "-4.242e+01     ");
-  test (sprintf "%015.3e" (-42.42) = "-000004.242e+01");
-  test (sprintf "%+.3e" 42.42 = "+4.242e+01");
-  test (sprintf "% .3e" 42.42 = " 4.242e+01");
-  test (sprintf "%#.3e" 42.42 = "4.242e+01");
-  test (sprintf "%15.3e" 42.42 = "      4.242e+01");
-  test (sprintf "%*.*e" 11 3 42.42 = "  4.242e+01");
-  test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01    ");
+  test (sprintf "%e" (-42.42) =* "-4.242000e+01");
+  test (sprintf "%-15e" (-42.42) =* "-4.242000e+01  ");
+  test (sprintf "%015e" (-42.42) =* "-004.242000e+01");
+  test (sprintf "%+e" 42.42 =* "+4.242000e+01");
+  test (sprintf "% e" 42.42 =* " 4.242000e+01");
+  test (sprintf "%#e" 42.42 =* "4.242000e+01");
+  test (sprintf "%15e" 42.42 =* "   4.242000e+01");
+  test (sprintf "%*e" 14 42.42 =* "  4.242000e+01");
+  test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");
+  test (sprintf "%.3e" (-42.42) =* "-4.242e+01");
+  test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01     ");
+  test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01");
+  test (sprintf "%+.3e" 42.42 =* "+4.242e+01");
+  test (sprintf "% .3e" 42.42 =* " 4.242e+01");
+  test (sprintf "%#.3e" 42.42 =* "4.242e+01");
+  test (sprintf "%15.3e" 42.42 =* "      4.242e+01");
+  test (sprintf "%*.*e" 11 3 42.42 =* "  4.242e+01");
+  test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01    ");
 
   printf "\nE\n%!";
-  test (sprintf "%E" (-42.42) = "-4.242000E+01");
-  test (sprintf "%-15E" (-42.42) = "-4.242000E+01  ");
-  test (sprintf "%015E" (-42.42) = "-004.242000E+01");
-  test (sprintf "%+E" 42.42 = "+4.242000E+01");
-  test (sprintf "% E" 42.42 = " 4.242000E+01");
-  test (sprintf "%#E" 42.42 = "4.242000E+01");
-  test (sprintf "%15E" 42.42 = "   4.242000E+01");
-  test (sprintf "%*E" 14 42.42 = "  4.242000E+01");
-  test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 ");
-  test (sprintf "%.3E" (-42.42) = "-4.242E+01");
-  test (sprintf "%-15.3E" (-42.42) = "-4.242E+01     ");
-  test (sprintf "%015.3E" (-42.42) = "-000004.242E+01");
-  test (sprintf "%+.3E" 42.42 = "+4.242E+01");
-  test (sprintf "% .3E" 42.42 = " 4.242E+01");
-  test (sprintf "%#.3E" 42.42 = "4.242E+01");
-  test (sprintf "%15.3E" 42.42 = "      4.242E+01");
-  test (sprintf "%*.*E" 11 3 42.42 = "  4.242E+01");
-  test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01    ");
+  test (sprintf "%E" (-42.42) =* "-4.242000E+01");
+  test (sprintf "%-15E" (-42.42) =* "-4.242000E+01  ");
+  test (sprintf "%015E" (-42.42) =* "-004.242000E+01");
+  test (sprintf "%+E" 42.42 =* "+4.242000E+01");
+  test (sprintf "% E" 42.42 =* " 4.242000E+01");
+  test (sprintf "%#E" 42.42 =* "4.242000E+01");
+  test (sprintf "%15E" 42.42 =* "   4.242000E+01");
+  test (sprintf "%*E" 14 42.42 =* "  4.242000E+01");
+  test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");
+  test (sprintf "%.3E" (-42.42) =* "-4.242E+01");
+  test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01     ");
+  test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01");
+  test (sprintf "%+.3E" 42.42 =* "+4.242E+01");
+  test (sprintf "% .3E" 42.42 =* " 4.242E+01");
+  test (sprintf "%#.3E" 42.42 =* "4.242E+01");
+  test (sprintf "%15.3E" 42.42 =* "      4.242E+01");
+  test (sprintf "%*.*E" 11 3 42.42 =* "  4.242E+01");
+  test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01    ");
 
 (* %g gives strange results that correspond to neither %f nor %e
   printf "\ng\n%!";
@@ -442,11 +464,14 @@ try
   let f () = "ok" in
   test (sprintf "%t" f = "ok");
 
-(* Does not work as expected.  Should be fixed to work like %s.
+  (* Work as expected. Prints the format string type digest.
+     If you want to print the contents of the format string,
+     do not use a meta format; simply convert the format string
+     to a string and print it using %s. *)
+
   printf "\n{...%%}\n%!";
-  let f = format_of_string "%f/%s" in
-  test (sprintf "%{%f%s%}" f = "%f/%s");
-*)
+  let f = format_of_string "%4g/%s" in
+  test (sprintf "%{%#0F%S%}" f = "%f%s");
 
   printf "\n(...%%)\n%!";
   let f = format_of_string "%d/foo/%s" in
diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference
index c30013eb..387dfb85 100644
--- a/testsuite/tests/lib-printf/tprintf.reference
+++ b/testsuite/tests/lib-printf/tprintf.reference
@@ -80,10 +80,12 @@ a
  266
 t
  267
-(...%)
+{...%}
  268
+(...%)
+ 269
 ! % @ , and constants
- 269 270 271 272 273 274 275
+ 270 271 272 273 274 275 276
 end of tests
 
 All tests succeeded.
diff --git a/testsuite/tests/lib-random/Makefile b/testsuite/tests/lib-random/Makefile
new file mode 100644
index 00000000..299656b2
--- /dev/null
+++ b/testsuite/tests/lib-random/Makefile
@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-random/rand.ml b/testsuite/tests/lib-random/rand.ml
new file mode 100644
index 00000000..e8c5cb8b
--- /dev/null
+++ b/testsuite/tests/lib-random/rand.ml
@@ -0,0 +1,6 @@
+let () =
+  Random.self_init ();
+  let x = Random.int 10000 in
+  Random.self_init ();
+  let y = Random.int 1000 in
+  if x = y then print_endline "FAILED" else print_endline "PASSED"
diff --git a/testsuite/tests/lib-random/rand.reference b/testsuite/tests/lib-random/rand.reference
new file mode 100644
index 00000000..53cdf1e9
--- /dev/null
+++ b/testsuite/tests/lib-random/rand.reference
@@ -0,0 +1 @@
+PASSED
diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile
index 7362fad9..6b8d56b0 100644
--- a/testsuite/tests/lib-scanf-2/Makefile
+++ b/testsuite/tests/lib-scanf-2/Makefile
@@ -1,30 +1,56 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
-default: compile run
+COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+.PHONY: default
+default:
+	@$(SET_LD_PATH) $(MAKE) compile run
 
+.PHONY: compile
 compile: tscanf2_io.cmo
+	@rm -f master.byte master.native master.native.exe
+	@rm -f slave.byte slave.native slave.native.exe
 	@$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
 	@$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
+	@if $(BYTECODE_ONLY); then : ; else \
 	  $(MAKE) tscanf2_io.cmx; \
-	  $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \
-	  $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \
+	  $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native$(EXE) \
+	              tscanf2_master.ml; \
+	  $(OCAMLOPT) tscanf2_io.cmx -o slave.native$(EXE) tscanf2_slave.ml; \
 	fi
 
 run:
 	@printf " ... testing with ocamlc"
-	@./master.byte ./slave.byte > result.byte 2>&1
-	@$(DIFF) reference result.byte > /dev/null || (echo " => failed" && exit 1)
-	@if [ -z "$(BYTECODE_ONLY)" ]; then \
-	  printf " ocamlopt" && \
-	  ./master.native ./slave.native > result.native 2>&1 && \
-	  $(DIFF) reference result.native > /dev/null || (echo " => failed" && exit 1) \
-	fi
-	@echo " => passed"
+	@$(OCAMLRUN) ./master.byte "$(OTOPDIR)/boot/ocamlrun$(EXE) \
+	                                     `$(CYGPATH) ./slave.byte`" \
+	             >result.byte 2>&1
+	@$(DIFF) reference result.byte >/dev/null \
+	&& if $(BYTECODE_ONLY); then : ; else \
+	     printf " ocamlopt"; \
+	     ./master.native$(EXE) "`$(CYGPATH) ./slave.native`" \
+	                           >result.native 2>&1; \
+	     $(DIFF) reference result.native >/dev/null; \
+	   fi \
+	&& echo " => passed" || echo " => failed"
 
+.PHONY: promote
 promote:
 	@cp result.byte reference
 
+.PHONY: clean
 clean: defaultclean
 	@rm -f master.* slave.* result.*
 
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_io.ml b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
index 03997897..b06ed877 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_io.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2005 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A very simple communication module using buffers. It should help detecting
    advanced character reading by Scanf when using stdin. *)
 
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_master.ml b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
index 2dd91bc0..a34cd013 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_master.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2005 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A very simple master:
    - first launch a slave process,
    - then repeat a random number of times:
diff --git a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
index e06a81f8..a444df18 100644
--- a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2005 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* A very simple slave:
    - read the string " Ping" on stdin,
    - then print the string "-pong" on stderr,
diff --git a/testsuite/tests/lib-scanf/Makefile b/testsuite/tests/lib-scanf/Makefile
index eba47014..55b0c005 100644
--- a/testsuite/tests/lib-scanf/Makefile
+++ b/testsuite/tests/lib-scanf/Makefile
@@ -1,8 +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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=tscanf
-ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib
 ADD_MODULES=testing
+TEST_TEMP_FILES=tscanf_data
 
 include $(BASEDIR)/makefiles/Makefile.one
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml
index 1ee1b4a2..53c92ffc 100644
--- a/testsuite/tests/lib-scanf/tscanf.ml
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -10,7 +10,7 @@
 (*                                                                       *)
 (*************************************************************************)
 
-(* $Id: tscanf.ml 12800 2012-07-30 18:59:07Z doligez $
+(*
 
 A testbed file for the module Scanf.
 
@@ -187,22 +187,7 @@ let unit fmt s =
 
 let test_fmt fmt s = unit fmt s = s;;
 
-(* The following test9_string is a result for test9 scanning.
-   Test9_string is the string "",
-   that is character i tréma, followed by french right guillemet,
-   followed by inverted question mark.
-   It is NOT the string "Ôªø",
-   that is uppercase o with circonflex accent, followed by commercial a,
-   followed by empty set.
-
-   In other words, the string "" has the following 3 characters
-   "\239\187\191".
-   It has NOT the characters "\212\170\248"!
-
-   Beware with automatic translation by your own local settings
-   (being your locale or your OS!)
-*)
-let test9_string = "";;
+let test9_string = "\239\187\191";;
 
 let test_S = test_fmt "%S";;
 let test9 () =
@@ -245,10 +230,10 @@ let test10 () =
   Scanf.bscanf ib "%S" id in
 
   let res =
-    sscanf "Une chaîne: \"celle-ci\" et \"celle-là\"!"
+    sscanf "Une chaine: \"celle-ci\" et \"celle-la\"!"
            "%s %s %S %s %S %s"
            (fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in
-  res = "Unechaîne:celle-cietcelle-là!" &&
+  res = "Unechaine:celle-cietcelle-la!" &&
   (* Testing the result of reading a %S string. *)
   unit "\"a\\\n  b\"" = "ab" &&
   unit "\"\\\n  ab\"" = "ab" &&
@@ -269,9 +254,9 @@ let test11 () =
     (fun prenom nom poids ->
      prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70)
   &&
-  sscanf "Jean-Luc\tde Léage\t68" "%[^\t] %[^\t] %d"
+  sscanf "Jean-Luc\tde Leage\t68" "%[^\t] %[^\t] %d"
     (fun prenom nom poids ->
-     prenom = "Jean-Luc" && nom = "de Léage" && poids = 68)
+     prenom = "Jean-Luc" && nom = "de Leage" && poids = 68)
   &&
   sscanf "Daniel\tde Rauglaudre\t66" "%s@\t %s@\t %d"
     (fun prenom nom poids ->
@@ -1355,7 +1340,7 @@ let get_lines fname =
     failwith (Printf.sprintf "in file %s, unexpected end of file" fname)
 ;;
 
-(* Simpy test that the list of lines read from the file are the list of lines
+(* Simply test that the list of lines read from the file is the list of lines
    written to it!. *)
 let test54 () =
   get_lines tscanf_data_file = tscanf_data_file_lines
diff --git a/testsuite/tests/lib-set/Makefile b/testsuite/tests/lib-set/Makefile
index 4ba0bffc..299656b2 100644
--- a/testsuite/tests/lib-set/Makefile
+++ b/testsuite/tests/lib-set/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
index c54764ea..8eee5e5f 100644
--- a/testsuite/tests/lib-set/testmap.ml
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -1,4 +1,16 @@
-module M = Map.Make(struct type t = int let compare = compare end)
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let img x m = try Some(M.find x m) with Not_found -> None
 
diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
index 024342f8..4f6626c1 100644
--- a/testsuite/tests/lib-set/testset.ml
+++ b/testsuite/tests/lib-set/testset.ml
@@ -1,4 +1,16 @@
-module S = Set.Make(struct type t = int let compare = compare end)
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let testvals = [0;1;2;3;4;5;6;7;8;9]
 
diff --git a/testsuite/tests/lib-str/Makefile b/testsuite/tests/lib-str/Makefile
index 35ad3003..6ae7266b 100644
--- a/testsuite/tests/lib-str/Makefile
+++ b/testsuite/tests/lib-str/Makefile
@@ -1,5 +1,19 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=str
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str
+LD_PATH=$(TOPDIR)/otherlibs/str
 
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml
index ab0c10eb..0a562b10 100644
--- a/testsuite/tests/lib-str/t01.ml
+++ b/testsuite/tests/lib-str/t01.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Printf
 
 let build_result ngroups input =
diff --git a/testsuite/tests/lib-stream/Makefile b/testsuite/tests/lib-stream/Makefile
index 65ecf125..e5bd381a 100644
--- a/testsuite/tests/lib-stream/Makefile
+++ b/testsuite/tests/lib-stream/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=testing
 include $(BASEDIR)/makefiles/Makefile.several
diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml
index 97ec6bce..986a2ea0 100644
--- a/testsuite/tests/lib-stream/count_concat_bug.ml
+++ b/testsuite/tests/lib-stream/count_concat_bug.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Gabriel Scherer, projet Gallium, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let is_empty s =
   try Stream.empty s; true with Stream.Failure -> false
 
diff --git a/testsuite/tests/lib-systhreads/Makefile b/testsuite/tests/lib-systhreads/Makefile
index 8729461a..fc098713 100644
--- a/testsuite/tests/lib-systhreads/Makefile
+++ b/testsuite/tests/lib-systhreads/Makefile
@@ -1,6 +1,20 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
 
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-systhreads/testfork.ml b/testsuite/tests/lib-systhreads/testfork.ml
index 1c1f232f..843e5ed2 100644
--- a/testsuite/tests/lib-systhreads/testfork.ml
+++ b/testsuite/tests/lib-systhreads/testfork.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* POSIX threads and fork() *)
 
 let compute_thread c = ignore c
diff --git a/testsuite/tests/lib-systhreads/testfork.precheck b/testsuite/tests/lib-systhreads/testfork.precheck
new file mode 100644
index 00000000..af81e807
--- /dev/null
+++ b/testsuite/tests/lib-systhreads/testfork.precheck
@@ -0,0 +1,17 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in
+  *' unix '*) exit 0;;
+  *) exit 3;;
+esac
+
diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile
index 8729461a..fc098713 100644
--- a/testsuite/tests/lib-threads/Makefile
+++ b/testsuite/tests/lib-threads/Makefile
@@ -1,6 +1,20 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 LIBRARIES=unix threads
-ADD_COMPFLAGS=-thread
+ADD_COMPFLAGS=-thread -I $(OTOPDIR)/otherlibs/systhreads \
+	      -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/systhreads:$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
 
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml
index 7bda2426..01b90afd 100644
--- a/testsuite/tests/lib-threads/close.ml
+++ b/testsuite/tests/lib-threads/close.ml
@@ -1,15 +1,30 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let main () =
   let (rd, wr) = Unix.pipe() in
-  let _ = Thread.create
+  let t = Thread.create
     (fun () ->
-      ignore (Unix.write wr "0123456789" 0 10);
-      Thread.delay 3.0;
+      Thread.delay 1.0;
       print_endline "closing fd...";
-      Unix.close rd)
+      Unix.close wr;
+    )
     () in
   let buf = String.create 10 in
   print_endline "reading...";
-  ignore (Unix.read rd buf 0 10);
-  print_endline "read returned"
+  begin try ignore (Unix.read rd buf 0 10) with Unix.Unix_error _ -> () end;
+  print_endline "read returned";
+  t
+
+let t = Unix.handle_unix_error main ()
 
-let _ = Unix.handle_unix_error main ()
+let _ = Thread.join t
diff --git a/testsuite/tests/lib-threads/close.reference b/testsuite/tests/lib-threads/close.reference
index 53b6e2a8..bb5061c8 100644
--- a/testsuite/tests/lib-threads/close.reference
+++ b/testsuite/tests/lib-threads/close.reference
@@ -1,2 +1,3 @@
 reading...
+closing fd...
 read returned
diff --git a/testsuite/tests/lib-threads/sieve.ml b/testsuite/tests/lib-threads/sieve.ml
index 72e26566..ac3a9d2f 100644
--- a/testsuite/tests/lib-threads/sieve.ml
+++ b/testsuite/tests/lib-threads/sieve.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Printf
 open Thread
 
@@ -28,6 +40,6 @@ let go max =
   in Thread.create (integers 2) ch;
      print_primes ch max;;
 
-let _ = go 1000
+let _ = go 500
 
 ;;
diff --git a/testsuite/tests/lib-threads/sieve.reference b/testsuite/tests/lib-threads/sieve.reference
index 1d0db087..3e7998db 100644
--- a/testsuite/tests/lib-threads/sieve.reference
+++ b/testsuite/tests/lib-threads/sieve.reference
@@ -93,76 +93,3 @@
 487
 491
 499
-503
-509
-521
-523
-541
-547
-557
-563
-569
-571
-577
-587
-593
-599
-601
-607
-613
-617
-619
-631
-641
-643
-647
-653
-659
-661
-673
-677
-683
-691
-701
-709
-719
-727
-733
-739
-743
-751
-757
-761
-769
-773
-787
-797
-809
-811
-821
-823
-827
-829
-839
-853
-857
-859
-863
-877
-881
-883
-887
-907
-911
-919
-929
-937
-941
-947
-953
-967
-971
-977
-983
-991
-997
diff --git a/testsuite/tests/lib-threads/test-file-short-lines b/testsuite/tests/lib-threads/test-file-short-lines
new file mode 100644
index 00000000..35abe7ca
--- /dev/null
+++ b/testsuite/tests/lib-threads/test-file-short-lines
@@ -0,0 +1,10 @@
+##
+# Host Database
+#
+# localhost is used to configure the loopback interface
+# when the system is booting.  Do not change this entry.
+##
+127.0.0.1	localhost
+255.255.255.255	broadcasthost
+::1             localhost 
+fe80::1%lo0	localhost
diff --git a/testsuite/tests/lib-threads/test1.checker b/testsuite/tests/lib-threads/test1.checker
index 1d104572..94778f23 100644
--- a/testsuite/tests/lib-threads/test1.checker
+++ b/testsuite/tests/lib-threads/test1.checker
@@ -1 +1,13 @@
-LC_ALL=C sort test1.result | diff -q test1.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT test1.result | $DIFF test1.reference -
diff --git a/testsuite/tests/lib-threads/test1.ml b/testsuite/tests/lib-threads/test1.ml
index 66c40240..8961b6f8 100644
--- a/testsuite/tests/lib-threads/test1.ml
+++ b/testsuite/tests/lib-threads/test1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Classic producer-consumer *)
 
 type 'a prodcons =
diff --git a/testsuite/tests/lib-threads/test2.checker b/testsuite/tests/lib-threads/test2.checker
index f9bc4271..75f6cf56 100644
--- a/testsuite/tests/lib-threads/test2.checker
+++ b/testsuite/tests/lib-threads/test2.checker
@@ -1 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 sed -e 1q test2.result | grep -q '^[ab]*'
diff --git a/testsuite/tests/lib-threads/test2.ml b/testsuite/tests/lib-threads/test2.ml
index 926f0907..85a5e65a 100644
--- a/testsuite/tests/lib-threads/test2.ml
+++ b/testsuite/tests/lib-threads/test2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let yield = ref false
 
 let print_message c =
diff --git a/testsuite/tests/lib-threads/test3.checker b/testsuite/tests/lib-threads/test3.checker
index 95fa0ed0..88fa4934 100644
--- a/testsuite/tests/lib-threads/test3.checker
+++ b/testsuite/tests/lib-threads/test3.checker
@@ -1 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 sed -e 1q test3.result | grep -q '^[ab]*'
diff --git a/testsuite/tests/lib-threads/test3.ml b/testsuite/tests/lib-threads/test3.ml
index c6df3326..1540363c 100644
--- a/testsuite/tests/lib-threads/test3.ml
+++ b/testsuite/tests/lib-threads/test3.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let print_message delay c =
   while true do
     print_char c; flush stdout; Thread.delay delay
diff --git a/testsuite/tests/lib-threads/test3.precheck b/testsuite/tests/lib-threads/test3.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test3.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test3.runner b/testsuite/tests/lib-threads/test3.runner
index e6d40a24..dc04062a 100644
--- a/testsuite/tests/lib-threads/test3.runner
+++ b/testsuite/tests/lib-threads/test3.runner
@@ -1,4 +1,16 @@
-./program > test3.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >test3.result &
 pid=$!
 sleep 5
 kill -9 $pid
diff --git a/testsuite/tests/lib-threads/test4.checker b/testsuite/tests/lib-threads/test4.checker
index b8661a98..38cc6186 100644
--- a/testsuite/tests/lib-threads/test4.checker
+++ b/testsuite/tests/lib-threads/test4.checker
@@ -1 +1,13 @@
-LC_ALL=C sort -u test4.result | diff -q test4.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT -u test4.result | $DIFF test4.reference -
diff --git a/testsuite/tests/lib-threads/test4.ml b/testsuite/tests/lib-threads/test4.ml
index 3acd9c60..7fb789c7 100644
--- a/testsuite/tests/lib-threads/test4.ml
+++ b/testsuite/tests/lib-threads/test4.ml
@@ -1,11 +1,24 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let output_lock = Mutex.create()
 
 let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2)
 
 let fibtask n =
   while true do
+    let res = fib n in
     Mutex.lock output_lock;
-    print_int(fib n); print_newline();
+    print_int res; print_newline();
     Mutex.unlock output_lock
   done
 
diff --git a/testsuite/tests/lib-threads/test4.runner b/testsuite/tests/lib-threads/test4.runner
index 0559da0f..43ac5632 100644
--- a/testsuite/tests/lib-threads/test4.runner
+++ b/testsuite/tests/lib-threads/test4.runner
@@ -1 +1,13 @@
-./program < test4.data > test4.result 2> /dev/null || true
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program test4.result 2>/dev/null || true
diff --git a/testsuite/tests/lib-threads/test5.checker b/testsuite/tests/lib-threads/test5.checker
index e9918757..5eef50b1 100644
--- a/testsuite/tests/lib-threads/test5.checker
+++ b/testsuite/tests/lib-threads/test5.checker
@@ -1 +1,13 @@
-LC_ALL=C sort -u test5.result | diff -q test5.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT -u test5.result | $DIFF test5.reference -
diff --git a/testsuite/tests/lib-threads/test5.ml b/testsuite/tests/lib-threads/test5.ml
index 3534d03b..24591919 100644
--- a/testsuite/tests/lib-threads/test5.ml
+++ b/testsuite/tests/lib-threads/test5.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Event
 
 let ch = (new_channel() : string channel)
diff --git a/testsuite/tests/lib-threads/test5.precheck b/testsuite/tests/lib-threads/test5.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test5.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test5.runner b/testsuite/tests/lib-threads/test5.runner
index 6973ea78..80dfe37e 100644
--- a/testsuite/tests/lib-threads/test5.runner
+++ b/testsuite/tests/lib-threads/test5.runner
@@ -1,4 +1,16 @@
-./program > test5.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >test5.result &
 pid=$!
 sleep 3
 kill -9 $pid
diff --git a/testsuite/tests/lib-threads/test6.checker b/testsuite/tests/lib-threads/test6.checker
index d2e9930a..cc00a631 100644
--- a/testsuite/tests/lib-threads/test6.checker
+++ b/testsuite/tests/lib-threads/test6.checker
@@ -1 +1,13 @@
-LC_ALL=C sort -u test6.result | diff -q test6.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT -u test6.result | $DIFF test6.reference -
diff --git a/testsuite/tests/lib-threads/test6.ml b/testsuite/tests/lib-threads/test6.ml
index 9573a661..1db9911d 100644
--- a/testsuite/tests/lib-threads/test6.ml
+++ b/testsuite/tests/lib-threads/test6.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Event
 
 let ch = (new_channel() : string channel)
diff --git a/testsuite/tests/lib-threads/test6.precheck b/testsuite/tests/lib-threads/test6.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test6.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test6.runner b/testsuite/tests/lib-threads/test6.runner
index 96bca7d7..50f88d8c 100644
--- a/testsuite/tests/lib-threads/test6.runner
+++ b/testsuite/tests/lib-threads/test6.runner
@@ -1,4 +1,16 @@
-./program > test6.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >test6.result &
 pid=$!
 sleep 1
 kill -9 $pid
diff --git a/testsuite/tests/lib-threads/test7.checker b/testsuite/tests/lib-threads/test7.checker
index 7cdb8412..55396e13 100644
--- a/testsuite/tests/lib-threads/test7.checker
+++ b/testsuite/tests/lib-threads/test7.checker
@@ -1 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l`
diff --git a/testsuite/tests/lib-threads/test7.ml b/testsuite/tests/lib-threads/test7.ml
index 0ac34742..9dae688f 100644
--- a/testsuite/tests/lib-threads/test7.ml
+++ b/testsuite/tests/lib-threads/test7.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Event
 
 let add_ch = new_channel()
diff --git a/testsuite/tests/lib-threads/test7.precheck b/testsuite/tests/lib-threads/test7.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test7.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test7.runner b/testsuite/tests/lib-threads/test7.runner
index c1e163db..ccd56a31 100644
--- a/testsuite/tests/lib-threads/test7.runner
+++ b/testsuite/tests/lib-threads/test7.runner
@@ -1,4 +1,16 @@
-./program > test7.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >test7.result &
 pid=$!
 sleep 1
 kill -9 $pid
diff --git a/testsuite/tests/lib-threads/test8.ml b/testsuite/tests/lib-threads/test8.ml
index 897fd09e..b3d1025d 100644
--- a/testsuite/tests/lib-threads/test8.ml
+++ b/testsuite/tests/lib-threads/test8.ml
@@ -1,22 +1,38 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Event
 
-type 'a buffer_channel = { input: 'a channel; output: 'a channel }
+type 'a buffer_channel = {
+  input: 'a channel;
+  output: 'a channel;
+  thread: Thread.t;
+}
 
 let new_buffer_channel() =
   let ic = new_channel() in
   let oc = new_channel() in
-  let buff = Queue.create() in
   let rec buffer_process front rear =
     match (front, rear) with
-      ([], []) -> buffer_process [sync(receive ic)] []
+    | (["EOF"], []) -> Thread.exit ()
+    | ([], []) -> buffer_process [sync(receive ic)] []
     | (hd::tl, _) ->
         select [
           wrap (receive ic) (fun x -> buffer_process front (x::rear));
           wrap (send oc hd) (fun () -> buffer_process tl rear)
         ]
     | ([], _) -> buffer_process (List.rev rear) [] in
-  Thread.create (buffer_process []) [];
-  { input = ic; output = oc }
+  let t = Thread.create (buffer_process []) [] in
+  { input = ic; output = oc; thread = t }
 
 let buffer_send bc data =
   sync(send bc.input data)
@@ -40,5 +56,8 @@ let g () =
   print_string (sync(buffer_receive box)); print_newline()
 
 let _ =
-  Thread.create f ();
-  g()
+  let t = Thread.create f () in
+  g();
+  buffer_send box "EOF";
+  Thread.join box.thread;
+  Thread.join t
diff --git a/testsuite/tests/lib-threads/test8.precheck b/testsuite/tests/lib-threads/test8.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test8.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test9.checker b/testsuite/tests/lib-threads/test9.checker
new file mode 100644
index 00000000..09dd0e25
--- /dev/null
+++ b/testsuite/tests/lib-threads/test9.checker
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT test9.result | $DIFF test9.reference -
diff --git a/testsuite/tests/lib-threads/test9.ml b/testsuite/tests/lib-threads/test9.ml
index 1f80beb8..16d61e04 100644
--- a/testsuite/tests/lib-threads/test9.ml
+++ b/testsuite/tests/lib-threads/test9.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Event
 
 type 'a swap_chan = ('a * 'a channel) channel
diff --git a/testsuite/tests/lib-threads/test9.precheck b/testsuite/tests/lib-threads/test9.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/test9.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/test9.reference b/testsuite/tests/lib-threads/test9.reference
index 0be61d12..58dc8b58 100644
--- a/testsuite/tests/lib-threads/test9.reference
+++ b/testsuite/tests/lib-threads/test9.reference
@@ -1,2 +1,2 @@
-g F
 f G
+g F
diff --git a/testsuite/tests/lib-threads/testA.checker b/testsuite/tests/lib-threads/testA.checker
index 9f5d00a8..00fdfb7a 100644
--- a/testsuite/tests/lib-threads/testA.checker
+++ b/testsuite/tests/lib-threads/testA.checker
@@ -1 +1,13 @@
-LC_ALL=C sort testA.result | diff -q testA.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT testA.result | $DIFF testA.reference -
diff --git a/testsuite/tests/lib-threads/testA.ml b/testsuite/tests/lib-threads/testA.ml
index 25c2f6e0..bdd33c34 100644
--- a/testsuite/tests/lib-threads/testA.ml
+++ b/testsuite/tests/lib-threads/testA.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
 let private_data_lock = Mutex.create()
 let output_lock = Mutex.create()
diff --git a/testsuite/tests/lib-threads/testexit.checker b/testsuite/tests/lib-threads/testexit.checker
index c1182d6f..55dcd7ba 100644
--- a/testsuite/tests/lib-threads/testexit.checker
+++ b/testsuite/tests/lib-threads/testexit.checker
@@ -1 +1,13 @@
-LC_ALL=C sort testexit.result | diff -q testexit.reference -
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+LC_ALL=C $SORT testexit.result | $DIFF testexit.reference -
diff --git a/testsuite/tests/lib-threads/testexit.ml b/testsuite/tests/lib-threads/testexit.ml
index 4564a483..b0cb80d6 100644
--- a/testsuite/tests/lib-threads/testexit.ml
+++ b/testsuite/tests/lib-threads/testexit.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test Thread.exit *)
 
 let somethread (name, limit, last) =
diff --git a/testsuite/tests/lib-threads/testio.ml b/testsuite/tests/lib-threads/testio.ml
index 80eac296..de0e4136 100644
--- a/testsuite/tests/lib-threads/testio.ml
+++ b/testsuite/tests/lib-threads/testio.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test a file copy function *)
 
 let test msg producer consumer src dst =
@@ -107,7 +119,7 @@ let main() =
   test "0...8192 byte chunks"
        (copy_random 8192) (copy_random 8192) ifile ofile;
   test "line per line, short lines"
-       copy_line copy_line "/etc/hosts" ofile;
+       copy_line copy_line "test-file-short-lines" ofile;
   let linesfile = Filename.temp_file "lines" "" in
   make_lines linesfile;
   test "line per line, short and long lines"
diff --git a/testsuite/tests/lib-threads/testsieve.ml b/testsuite/tests/lib-threads/testsieve.ml
index 6079d8a8..6979f803 100644
--- a/testsuite/tests/lib-threads/testsieve.ml
+++ b/testsuite/tests/lib-threads/testsieve.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let sieve primes=
   Event.sync (Event.send primes 0);
   Event.sync (Event.send primes 1);
diff --git a/testsuite/tests/lib-threads/testsignal.checker b/testsuite/tests/lib-threads/testsignal.checker
index e7a5f061..3febbff4 100644
--- a/testsuite/tests/lib-threads/testsignal.checker
+++ b/testsuite/tests/lib-threads/testsignal.checker
@@ -1 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 sed -e 1q testsignal.result | grep -q '^[ab]*Got ctrl-C, exiting...$'
diff --git a/testsuite/tests/lib-threads/testsignal.ml b/testsuite/tests/lib-threads/testsignal.ml
index 7781f337..67fa75f7 100644
--- a/testsuite/tests/lib-threads/testsignal.ml
+++ b/testsuite/tests/lib-threads/testsignal.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let sighandler _ =
   print_string "Got ctrl-C, exiting..."; print_newline();
   exit 0
diff --git a/testsuite/tests/lib-threads/testsignal.precheck b/testsuite/tests/lib-threads/testsignal.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/testsignal.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/testsignal.runner b/testsuite/tests/lib-threads/testsignal.runner
index 74c0d54d..ed4e9279 100644
--- a/testsuite/tests/lib-threads/testsignal.runner
+++ b/testsuite/tests/lib-threads/testsignal.runner
@@ -1,4 +1,16 @@
-./program > testsignal.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >testsignal.result &
 pid=$!
 sleep 3
 kill -INT $pid
diff --git a/testsuite/tests/lib-threads/testsignal2.checker b/testsuite/tests/lib-threads/testsignal2.checker
index 6808a265..47ede358 100644
--- a/testsuite/tests/lib-threads/testsignal2.checker
+++ b/testsuite/tests/lib-threads/testsignal2.checker
@@ -1 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 sed -e 1q testsignal2.result | grep -q '^[ab]*'
diff --git a/testsuite/tests/lib-threads/testsignal2.ml b/testsuite/tests/lib-threads/testsignal2.ml
index c73bdb99..e59a8557 100644
--- a/testsuite/tests/lib-threads/testsignal2.ml
+++ b/testsuite/tests/lib-threads/testsignal2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let print_message delay c =
   while true do
     print_char c; flush stdout; Thread.delay delay
diff --git a/testsuite/tests/lib-threads/testsignal2.precheck b/testsuite/tests/lib-threads/testsignal2.precheck
new file mode 100644
index 00000000..aa357092
--- /dev/null
+++ b/testsuite/tests/lib-threads/testsignal2.precheck
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$CANKILL
diff --git a/testsuite/tests/lib-threads/testsignal2.runner b/testsuite/tests/lib-threads/testsignal2.runner
index e215ec6e..19a3942f 100644
--- a/testsuite/tests/lib-threads/testsignal2.runner
+++ b/testsuite/tests/lib-threads/testsignal2.runner
@@ -1,4 +1,16 @@
-./program > testsignal2.result &
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program >testsignal2.result &
 pid=$!
 sleep 3
 kill -INT $pid
diff --git a/testsuite/tests/lib-threads/testsocket.ml b/testsuite/tests/lib-threads/testsocket.ml
index c5fc40b1..ec16c058 100644
--- a/testsuite/tests/lib-threads/testsocket.ml
+++ b/testsuite/tests/lib-threads/testsocket.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Unix
 
 let engine verbose number address =
diff --git a/testsuite/tests/lib-threads/testsocket.precheck b/testsuite/tests/lib-threads/testsocket.precheck
new file mode 100644
index 00000000..15ae35c5
--- /dev/null
+++ b/testsuite/tests/lib-threads/testsocket.precheck
@@ -0,0 +1,23 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+
+##########################################
+##########################################
+####  TEMPORARY                       ####
+##########################################
+##########################################
+
+# disable this test on Windows non-cygwin ports until we decide
+# how to fix PR#5325 and PR#5578
+
+$CANKILL
\ No newline at end of file
diff --git a/testsuite/tests/lib-threads/token1.ml b/testsuite/tests/lib-threads/token1.ml
index 5dab410b..d6e7a1b7 100644
--- a/testsuite/tests/lib-threads/token1.ml
+++ b/testsuite/tests/lib-threads/token1.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Performance test for mutexes and conditions *)
 
 let mut = Mutex.create()
diff --git a/testsuite/tests/lib-threads/token2.ml b/testsuite/tests/lib-threads/token2.ml
index 32f2c6ed..9ef05806 100644
--- a/testsuite/tests/lib-threads/token2.ml
+++ b/testsuite/tests/lib-threads/token2.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Performance test for I/O scheduling *)
 
 let mut = Mutex.create()
@@ -7,13 +19,13 @@ let niter = ref 0
 let token = ref 0
 
 let process (n, ins, outs, nprocs) =
-  let buf = String.create 1 in
-  while true do
+  let buf = String.make 1 '.' in
+  while buf <> "-" do
     Unix.read ins.(n) buf 0 1;
     (* Printf.printf "Thread %d got the token\n" n; *)
     if n = 0 then begin
       decr niter;
-      if !niter <= 0 then exit 0
+      if !niter <= 0 then buf.[0] <- '-';
     end;
     let next = if n + 1 >= nprocs then 0 else n + 1 in
     (* Printf.printf "Thread %d sending token to thread %d\n" n next; *)
@@ -25,12 +37,15 @@ let main() =
   let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in
   let ins = Array.create nprocs Unix.stdin in
   let outs = Array.create nprocs Unix.stdout in
+  let threads = Array.create nprocs (Thread.self ()) in
   for n = 0 to nprocs - 1 do
     let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o
   done;
   niter := iter;
-  for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done;
+  for i = 0 to nprocs - 1 do
+    threads.(i) <- Thread.create process (i, ins, outs, nprocs)
+  done;
   Unix.write outs.(0) "X" 0 1;
-  Thread.delay 3600.
+  for i = 0 to nprocs - 1 do Thread.join threads.(i) done
 
 let _ = main()
diff --git a/testsuite/tests/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml
index 02006a7a..0c1a3a3a 100644
--- a/testsuite/tests/lib-threads/torture.ml
+++ b/testsuite/tests/lib-threads/torture.ml
@@ -1,25 +1,41 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Torture test - lots of GC *)
 
+let finished = ref false;;
+
 let gc_thread () =
-  while true do
+  while not !finished do
 (*    print_string "gc"; print_newline(); *)
     Gc.minor();
     Thread.yield()
   done
 
 let stdin_thread () =
-  while true do
+  while not !finished do
     print_string ">"; flush stdout;
     let s = read_line() in
     print_string " >>> "; print_string s; print_newline()
   done
 
 let writer_thread (oc, size) =
-  while true do
+  while not !finished do
 (*    print_string "writer "; print_int size; print_newline(); *)
     let buff = String.make size 'a' in
     Unix.write oc buff 0 size
-  done
+  done;
+  let buff = String.make size 'b' in
+  Unix.write oc buff 0 size
 
 let reader_thread (ic, size) =
   while true do
@@ -28,18 +44,23 @@ let reader_thread (ic, size) =
     let n = Unix.read ic buff 0 size in
 (*    print_string "reader "; print_int n; print_newline(); *)
     for i = 0 to n-1 do
-      if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
+      if buff.[i] = 'b' then raise Exit
+      else if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
     done
   done
 
 let main() =
-  Thread.create gc_thread ();
+  let t1 = Thread.create gc_thread () in
   let (out1, in1) = Unix.pipe() in
-  Thread.create writer_thread (in1, 4096);
-  Thread.create reader_thread (out1, 4096);
+  let t2 = Thread.create writer_thread (in1, 4096) in
+  let t3 = Thread.create reader_thread (out1, 4096) in
   let (out2, in2) = Unix.pipe() in
-  Thread.create writer_thread (in2, 16);
-  Thread.create reader_thread (out2, 16);
-  stdin_thread()
+  let t4 = Thread.create writer_thread (in2, 16) in
+  let t5 = Thread.create reader_thread (out2, 16) in
+  try
+    stdin_thread()
+  with _ ->
+    finished := true;
+    List.iter Thread.join [t1; t2; t3; t4; t5]
 
 let _ = main()
diff --git a/testsuite/tests/lib-threads/torture.runner b/testsuite/tests/lib-threads/torture.runner
index 12ceeb64..fc1ed387 100644
--- a/testsuite/tests/lib-threads/torture.runner
+++ b/testsuite/tests/lib-threads/torture.runner
@@ -1 +1,13 @@
-./program < torture.data > torture.result 2> /dev/null || true
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$RUNTIME ./program torture.result 2>/dev/null || true
diff --git a/testsuite/tests/misc-kb/Makefile b/testsuite/tests/misc-kb/Makefile
index 1802e554..98bcd7c5 100644
--- a/testsuite/tests/misc-kb/Makefile
+++ b/testsuite/tests/misc-kb/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=terms equations orderings kb
 MAIN_MODULE=kbmain
diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
index d45bd7d6..0ea3bb11 100644
--- a/testsuite/tests/misc-kb/equations.ml
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: equations.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (****************** Equation manipulations *************)
 
 open Terms
diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
index c9ea8aac..db80f481 100644
--- a/testsuite/tests/misc-kb/equations.mli
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: equations.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Terms
 
 type rule =
diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
index 9af59194..0892a90c 100644
--- a/testsuite/tests/misc-kb/kb.ml
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: kb.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Terms
 open Equations
 
diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
index 405aae5e..c0578e56 100644
--- a/testsuite/tests/misc-kb/kb.mli
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: kb.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Terms
 open Equations
 
diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
index 8e918c58..753f7353 100644
--- a/testsuite/tests/misc-kb/kbmain.ml
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: kbmain.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Terms
 open Equations
 open Orderings
diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
index 81b06196..488f8703 100644
--- a/testsuite/tests/misc-kb/orderings.ml
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: orderings.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (*********************** Recursive Path Ordering ****************************)
 
 open Terms
diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
index 5d5a4c2b..d67e3796 100644
--- a/testsuite/tests/misc-kb/orderings.mli
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: orderings.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Terms
 
 type ordering =
diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
index bc3cd64b..b490c81f 100644
--- a/testsuite/tests/misc-kb/terms.ml
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terms.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (****************** Term manipulations *****************)
 
 type term =
diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
index c80d8423..aa1dd2cd 100644
--- a/testsuite/tests/misc-kb/terms.mli
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terms.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 type term =
     Var of int
   | Term of string * term list
diff --git a/testsuite/tests/misc-unsafe/Makefile b/testsuite/tests/misc-unsafe/Makefile
index f4a8b4e3..4a70866f 100644
--- a/testsuite/tests/misc-unsafe/Makefile
+++ b/testsuite/tests/misc-unsafe/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 UNSAFE=ON
 include $(BASEDIR)/makefiles/Makefile.several
diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
index eb13b1e0..2c1cf38b 100644
--- a/testsuite/tests/misc-unsafe/fft.ml
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fft.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 let pi = 3.14159265358979323846
 
 let tpi = 2.0 *. pi
diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
index 99cc56c1..4f872fd2 100644
--- a/testsuite/tests/misc-unsafe/quicksort.ml
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: quicksort.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Good test for loops. Best compiled with -unsafe. *)
 
 let rec qsort lo hi (a : int array) =
diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index 05a220fb..e4aa7215 100644
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -10,9 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: soli.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
-
 type peg = Out | Empty | Peg
 
 let board = [|
diff --git a/testsuite/tests/misc/Makefile b/testsuite/tests/misc/Makefile
index 4ba0bffc..299656b2 100644
--- a/testsuite/tests/misc/Makefile
+++ b/testsuite/tests/misc/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml
index 5cc88a0e..954edc16 100644
--- a/testsuite/tests/misc/bdd.ml
+++ b/testsuite/tests/misc/bdd.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: bdd.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Translated to OCaml by Xavier Leroy *)
 (* Original code written in SML by ... *)
 
diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
index 6b6e3f2e..09bfd649 100644
--- a/testsuite/tests/misc/boyer.ml
+++ b/testsuite/tests/misc/boyer.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: boyer.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Manipulations over terms *)
 
 type term =
diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
index 71fe1610..adaf5488 100644
--- a/testsuite/tests/misc/fib.ml
+++ b/testsuite/tests/misc/fib.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: fib.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 let rec fib n =
   if n < 2 then 1 else fib(n-1) + fib(n-2)
 
diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
index 29b209b4..7c49c2b4 100644
--- a/testsuite/tests/misc/hamming.ml
+++ b/testsuite/tests/misc/hamming.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: hamming.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* We cannot use bignums because we don't do custom runtimes, but
    int64 is a bit short, so we roll our own 37-digit numbers...
 *)
diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
index 09c8c483..6b5b196f 100644
--- a/testsuite/tests/misc/nucleic.ml
+++ b/testsuite/tests/misc/nucleic.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: nucleic.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Use floating-point arithmetic *)
 
 external (+) : float -> float -> float = "%addfloat"
diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
index 0e8685f1..7d8d21bd 100644
--- a/testsuite/tests/misc/sieve.ml
+++ b/testsuite/tests/misc/sieve.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: sieve.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Eratosthene's sieve *)
 
 (* interval min max = [min; min+1; ...; max-1; max] *)
diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml
index a457761f..db9ecae5 100644
--- a/testsuite/tests/misc/sorts.ml
+++ b/testsuite/tests/misc/sorts.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Moscova, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Test bench for sorting algorithms. *)
 
 
@@ -451,7 +463,7 @@ let bench3c limit name f aux =
   let cmp = aux.prepf compare (<=) in
   table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n));
 ;;
-
+
 (************************************************************************)
 (* merge sort on lists *)
 
@@ -501,7 +513,7 @@ let lmerge_1a cmp l =
   in
   mergeall_rev (init [] l)
 ;;
-
+
 let lmerge_1b cmp l =
   let rec init accu = function
     | [] -> accu
@@ -544,7 +556,7 @@ let lmerge_1b cmp l =
   in
   mergeall_rev (init [] l)
 ;;
-
+
 let lmerge_1c cmp l =
   let rec init accu = function
     | [] -> accu
@@ -591,7 +603,7 @@ let lmerge_1c cmp l =
   in
   mergeall_rev (init [] l)
 ;;
-
+
 let lmerge_1d cmp l =
   let rec init accu = function
     | [] -> accu
@@ -642,7 +654,7 @@ let lmerge_1d cmp l =
   in
   mergeall_rev (init [] l)
 ;;
-
+
 (************************************************************************)
 (* merge sort on lists, user-contributed (NOT STABLE) *)
 
@@ -704,7 +716,7 @@ let lmerge_1d cmp l =
     mergeall false (initlist l [])
 
 (* END code contributed by Yann Coscoy *)
-
+
 (************************************************************************)
 (* merge sort on short lists, Francois Pottier *)
 
@@ -760,7 +772,7 @@ let lmerge_1d cmp l =
         sort (List.length l) l
   ;;
 (* END code contributed by Francois Pottier *)
-
+
 (************************************************************************)
 (* merge sort on short lists, Francois Pottier,
    adapted to new-style interface *)
@@ -817,7 +829,7 @@ let lmerge_1d cmp l =
         sort (List.length l) l
   ;;
 (* END code contributed by Francois Pottier *)
-
+
 (************************************************************************)
 (* merge sort on short lists a la Pottier, modified merge *)
 
@@ -871,7 +883,7 @@ let lmerge_4c cmp l =
   let len = List.length l in
   if len < 2 then l else sort len l
 ;;
-
+
 (************************************************************************)
 (* merge sort on short lists a la Pottier, logarithmic stack space *)
 
@@ -943,7 +955,7 @@ let lmerge_4d cmp l =
   if len < 2 then l else sort len l
 ;;
 
-
+
 (************************************************************************)
 (* merge sort on short lists a la Pottier, logarithmic stack space,
    in place: input list is freed as the output is being computed. *)
@@ -1021,7 +1033,7 @@ let lmerge_4e cmp l =
   let len = List.length l in
   if len < 2 then l else sort len l
 ;;
-
+
 (************************************************************************)
 (* chop-free version of Pottier's code, binary version *)
 
@@ -1055,7 +1067,7 @@ let lmerge_5a cmp l =
   while !len > 0 do incr i; len := !len lsr 1; done;
   sort_prefix !i
 ;;
-
+
 (************************************************************************)
 (* chop-free version of Pottier's code, dichotomic version,
    ground cases 1 & 2 *)
@@ -1086,7 +1098,7 @@ let lmerge_5b cmp l =
   let len = List.length l in
   if len <= 1 then l else sort_prefix len
 ;;
-
+
 (************************************************************************)
 (* chop-free version of Pottier's code, dichotomic version,
    ground cases 2 & 3 *)
@@ -1126,7 +1138,7 @@ let lmerge_5c cmp l =
   let len = List.length l in
   if len <= 1 then l else sort_prefix len
 ;;
-
+
 (************************************************************************)
 (* chop-free, ref-free version of Pottier's code, dichotomic version,
    ground cases 2 & 3, modified merge *)
@@ -1171,7 +1183,7 @@ let lmerge_5d cmp l =
   let len = List.length l in
   if len <= 1 then l else fst (sort_prefix len l)
 ;;
-
+
 (************************************************************************)
 (* merge sort on arrays, merge with tail-rec function *)
 
@@ -1218,7 +1230,7 @@ let amerge_1a cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let amerge_1b cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
     let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
@@ -1276,7 +1288,7 @@ let amerge_1b cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 3;;
 let amerge_1c cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1329,7 +1341,7 @@ let amerge_1c cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 4;;
 let amerge_1d cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1382,7 +1394,7 @@ let amerge_1d cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 5;;
 let amerge_1e cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1435,7 +1447,7 @@ let amerge_1e cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 6;;
 let amerge_1f cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1488,7 +1500,7 @@ let amerge_1f cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 7;;
 let amerge_1g cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1541,7 +1553,7 @@ let amerge_1g cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 8;;
 let amerge_1h cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1594,7 +1606,7 @@ let amerge_1h cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 9;;
 let amerge_1i cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1647,7 +1659,7 @@ let amerge_1i cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 10;;
 let amerge_1j cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1700,13 +1712,13 @@ let amerge_1j cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 (* FIXME a essayer: *)
 (* list->array->list direct et array->list->array direct *)
 (* overhead = 1/3, 1/4, etc. *)
 (* overhead = sqrt (n) *)
 (* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *)
-
+
 (************************************************************************)
 (* merge sort on arrays, merge with loop *)
 
@@ -1754,7 +1766,7 @@ let amerge_3a cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let amerge_3b cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
     let i1 = ref src1ofs
@@ -1815,7 +1827,7 @@ let amerge_3b cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 3;;
 let amerge_3c cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1870,7 +1882,7 @@ let amerge_3c cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 4;;
 let amerge_3d cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1925,7 +1937,7 @@ let amerge_3d cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 5;;
 let amerge_3e cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -1980,7 +1992,7 @@ let amerge_3e cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 6;;
 let amerge_3f cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -2035,7 +2047,7 @@ let amerge_3f cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 7;;
 let amerge_3g cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -2090,7 +2102,7 @@ let amerge_3g cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 8;;
 let amerge_3h cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -2145,7 +2157,7 @@ let amerge_3h cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 9;;
 let amerge_3i cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -2200,7 +2212,7 @@ let amerge_3i cmp a =
     merge l2 l1 t 0 l2 a 0;
   end;
 ;;
-
+
 let cutoff = 10;;
 let amerge_3j cmp a =
   let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
@@ -2257,7 +2269,7 @@ let amerge_3j cmp a =
 ;;
 
 (* FIXME essayer bottom-up merge on arrays ? *)
-
+
 (************************************************************************)
 (* Shell sort on arrays *)
 
@@ -2281,7 +2293,7 @@ let ashell_1 cmp a =
     step := !step / 3;
   done;
 ;;
-
+
 let ashell_2 cmp a =
   let l = Array.length a in
   let step = ref 1 in
@@ -2300,7 +2312,7 @@ let ashell_2 cmp a =
     step := !step / 3;
   done;
 ;;
-
+
 let ashell_3 cmp a =
   let l = Array.length a in
   let step = ref 1 in
@@ -2326,7 +2338,7 @@ let ashell_3 cmp a =
     step := !step / 3;
   done;
 ;;
-
+
 let force = Lazy.force;;
 
 type iilist = Cons of int * iilist Lazy.t;;
@@ -2367,7 +2379,7 @@ let ashell_4 cmp a =
   in
   loop2 sc;
 ;;
-
+
 (************************************************************************)
 (* Quicksort on arrays *)
 let cutoff = 1;;
@@ -2431,7 +2443,7 @@ let aquick_1a cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 2;;
 let aquick_1b cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2493,7 +2505,7 @@ let aquick_1b cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 3;;
 let aquick_1c cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2555,7 +2567,7 @@ let aquick_1c cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 4;;
 let aquick_1d cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2617,7 +2629,7 @@ let aquick_1d cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 5;;
 let aquick_1e cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2679,7 +2691,7 @@ let aquick_1e cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 6;;
 let aquick_1f cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2741,7 +2753,7 @@ let aquick_1f cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 7;;
 let aquick_1g cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2803,7 +2815,7 @@ let aquick_1g cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 1;;
 let aquick_2a cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2863,7 +2875,7 @@ let aquick_2a cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 2;;
 let aquick_2b cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2923,7 +2935,7 @@ let aquick_2b cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 3;;
 let aquick_2c cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -2983,7 +2995,7 @@ let aquick_2c cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 4;;
 let aquick_2d cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3043,7 +3055,7 @@ let aquick_2d cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 5;;
 let aquick_2e cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3103,7 +3115,7 @@ let aquick_2e cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 6;;
 let aquick_2f cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3163,7 +3175,7 @@ let aquick_2f cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 7;;
 let aquick_2g cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3223,7 +3235,7 @@ let aquick_2g cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 1;;
 let aquick_3a cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3288,7 +3300,7 @@ let aquick_3a cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 2;;
 let aquick_3b cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3353,7 +3365,7 @@ let aquick_3b cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 3;;
 let aquick_3c cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3418,7 +3430,7 @@ let aquick_3c cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 4;;
 let aquick_3d cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3483,7 +3495,7 @@ let aquick_3d cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 5;;
 let aquick_3e cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3548,7 +3560,7 @@ let aquick_3e cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 6;;
 let aquick_3f cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3613,7 +3625,7 @@ let aquick_3f cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 7;;
 let aquick_3g cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3678,7 +3690,7 @@ let aquick_3g cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 8;;
 let aquick_3h cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3743,7 +3755,7 @@ let aquick_3h cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 9;;
 let aquick_3i cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3808,7 +3820,7 @@ let aquick_3i cmp a =
     done;
   end;
 ;;
-
+
 let cutoff = 10;;
 let aquick_3j cmp a =
   let rec qsort l r =     (* ASSUMES r - l >= 2 *)
@@ -3873,7 +3885,7 @@ let aquick_3j cmp a =
     done;
   end;
 ;;
-
+
 (************************************************************************)
 (* Heap sort on arrays (top-down, ternary) *)
 
@@ -3913,7 +3925,7 @@ let aheap_1 cmp a =
   done;
   if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end;
 ;;
-
+
 (************************************************************************)
 (* Heap sort on arrays (top-down, binary) *)
 
@@ -3945,7 +3957,7 @@ let aheap_2 cmp a =
     down i 0 e;
   done;
 ;;
-
+
 (************************************************************************)
 (* Heap sort on arrays (bottom-up, ternary) *)
 
@@ -3999,7 +4011,7 @@ let aheap_3 cmp a =
   done;
   if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
 ;;
-
+
 (************************************************************************)
 (* Heap sort on arrays (bottom-up, binary) *)
 
@@ -4045,7 +4057,7 @@ let aheap_4 cmp a =
   done;
   if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e);
 ;;
-
+
 (************************************************************************)
 (* heap sort, top-down, ternary, recursive final loop *)
 
@@ -4102,7 +4114,7 @@ let aheap_5 cmp a =
     | 2 -> loop1 (l-1) l3;
     | _ -> assert false;
 ;;
-
+
 (************************************************************************)
 (* heap sort, top-down, ternary, with exception *)
 
@@ -4161,7 +4173,7 @@ let ainsertion_1 cmp a =
     a.(j) <- e;
   done;
 ;;
-
+
 (************************************************************************)
 (* merge sort on lists via arrays *)
 
@@ -4231,7 +4243,7 @@ let amerge_0 cmp a =    (* cutoff is not yet used *)
   in
   loop 0 l
 ;;
-
+
 (************************************************************************)
 
 let lold = [
@@ -4475,5 +4487,3 @@ let main () =
 ;;
 
 if not !Sys.interactive then Printexc.catch main ();;
-
-(* $Id: sorts.ml 11123 2011-07-20 09:17:07Z doligez $ *)
diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
index f7b244c9..667ff5a7 100644
--- a/testsuite/tests/misc/takc.ml
+++ b/testsuite/tests/misc/takc.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: takc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 let rec tak x y z =
   if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
            else z
diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
index cb7f7e66..47d94c88 100644
--- a/testsuite/tests/misc/taku.ml
+++ b/testsuite/tests/misc/taku.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: taku.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 let rec tak (x, y, z) =
   if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
            else z
diff --git a/testsuite/tests/misc/weaktest.ml b/testsuite/tests/misc/weaktest.ml
index 047e130b..ffeabf29 100644
--- a/testsuite/tests/misc/weaktest.ml
+++ b/testsuite/tests/misc/weaktest.ml
@@ -1,4 +1,14 @@
-(* $Id: weaktest.ml 11123 2011-07-20 09:17:07Z doligez $ *)
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
+(*                                                                       *)
+(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
 
 let debug = false;;
 
diff --git a/testsuite/tests/prim-bswap/Makefile b/testsuite/tests/prim-bswap/Makefile
new file mode 100644
index 00000000..956ab4a7
--- /dev/null
+++ b/testsuite/tests/prim-bswap/Makefile
@@ -0,0 +1,17 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                    Benedikt Meurer, os-cillation GmbH                 #
+#                                                                       #
+#     Copyright 1998 Institut National de Recherche en Informatique     #
+#     et en Automatique. Copyright 2013 Benedikt Meurer. All rights     #
+#     reserved.  This file is distributed  under the terms of the Q     #
+#     Public License version 1.0.                                       #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/prim-bswap/bswap.ml b/testsuite/tests/prim-bswap/bswap.ml
new file mode 100644
index 00000000..40ab21ff
--- /dev/null
+++ b/testsuite/tests/prim-bswap/bswap.ml
@@ -0,0 +1,30 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                   Benedikt Meurer, os-cillation GmbH                *)
+(*                                                                     *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2013 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Printf
+
+external bswap16: int -> int = "%bswap16"
+external bswap32: int32 -> int32 = "%bswap_int32"
+external bswap64: int64 -> int64 = "%bswap_int64"
+
+let d16 = [0x11223344;
+           0x0000f0f0]
+let d32 = [0x11223344l;
+           0xf0f0f0f0l]
+let d64 = [0x1122334455667788L;
+           0xf0f0f0f0f0f0f0f0L]
+
+let _ =
+  List.iter (fun x -> printf "%x\n" (bswap16 x)) d16;
+  List.iter (fun x -> printf "%lx\n" (bswap32 x)) d32;
+  List.iter (fun x -> printf "%Lx\n" (bswap64 x)) d64
diff --git a/testsuite/tests/prim-bswap/bswap.reference b/testsuite/tests/prim-bswap/bswap.reference
new file mode 100644
index 00000000..c08abb7f
--- /dev/null
+++ b/testsuite/tests/prim-bswap/bswap.reference
@@ -0,0 +1,6 @@
+4433
+f0f0
+44332211
+f0f0f0f0
+8877665544332211
+f0f0f0f0f0f0f0f0
diff --git a/testsuite/tests/prim-revapply/Makefile b/testsuite/tests/prim-revapply/Makefile
index bcc2fdb0..6e8d01ff 100644
--- a/testsuite/tests/prim-revapply/Makefile
+++ b/testsuite/tests/prim-revapply/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
 include $(BASEDIR)/makefiles/Makefile.several
diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
index 1a169e18..e873c484 100644
--- a/testsuite/tests/prim-revapply/apply.ml
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Fabrice Le Fessant, INRIA Saclay                   *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
 
 let f x = x + x
diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
index f8b0dc2e..d869163e 100644
--- a/testsuite/tests/prim-revapply/revapply.ml
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Fabrice Le Fessant, INRIA Saclay                   *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 
 let f x = x + x
diff --git a/testsuite/tests/regression/camlp4-class-type-plus/Makefile b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
index a539d51a..7499c3de 100644
--- a/testsuite/tests/regression/camlp4-class-type-plus/Makefile
+++ b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 ADD_COMPFLAGS = -pp 'camlp4o'
 MAIN_MODULE = camlp4_class_type_plus_ok
 
diff --git a/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml b/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
index 79ba26d8..89d1b9ad 100644
--- a/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
+++ b/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2011 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.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 type t;;
 type xdr_value;;
 
diff --git a/testsuite/tests/regression/pr5080-notes/Makefile b/testsuite/tests/regression/pr5080-notes/Makefile
index ddc4d552..8079539b 100644
--- a/testsuite/tests/regression/pr5080-notes/Makefile
+++ b/testsuite/tests/regression/pr5080-notes/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
 MAIN_MODULE = pr5080_notes_ok
 
diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
index 175bc8b7..f043f397 100644
--- a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2011 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let marshal_int f  =
   match [] with
   | _ :: `INT n :: _ -> f n
diff --git a/testsuite/tests/regression/pr5233/Makefile b/testsuite/tests/regression/pr5233/Makefile
index c7a1ed0e..7c875051 100644
--- a/testsuite/tests/regression/pr5233/Makefile
+++ b/testsuite/tests/regression/pr5233/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 MAIN_MODULE=pr5233
 
 include ../../../makefiles/Makefile.one
diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml
index d0b5f762..75aec4f9 100644
--- a/testsuite/tests/regression/pr5233/pr5233.ml
+++ b/testsuite/tests/regression/pr5233/pr5233.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Printf;;
 
 (* PR#5233: Create a dangling pointer and use it to access random parts
diff --git a/testsuite/tests/regression/pr5757/Makefile b/testsuite/tests/regression/pr5757/Makefile
index a31a394e..d0eb0542 100644
--- a/testsuite/tests/regression/pr5757/Makefile
+++ b/testsuite/tests/regression/pr5757/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 MAIN_MODULE=pr5757
 
 include ../../../makefiles/Makefile.one
diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml
index 22b36d73..5395840c 100644
--- a/testsuite/tests/regression/pr5757/pr5757.ml
+++ b/testsuite/tests/regression/pr5757/pr5757.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 Random.init 3;;
 for i = 0 to 100_000 do
   ignore (String.create (Random.int 1_000_000))
diff --git a/testsuite/tests/regression/pr6024/Makefile b/testsuite/tests/regression/pr6024/Makefile
new file mode 100644
index 00000000..964eefce
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/Makefile
@@ -0,0 +1,16 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+MAIN_MODULE=pr6024
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr6024/pr6024.ml b/testsuite/tests/regression/pr6024/pr6024.ml
new file mode 100644
index 00000000..b440cb2d
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/pr6024.ml
@@ -0,0 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+Format.printf "@[%@-@@-@]@.";;
diff --git a/testsuite/tests/regression/pr6024/pr6024.reference b/testsuite/tests/regression/pr6024/pr6024.reference
new file mode 100644
index 00000000..67182723
--- /dev/null
+++ b/testsuite/tests/regression/pr6024/pr6024.reference
@@ -0,0 +1 @@
+@-@-
diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile
index 249a1bbf..b5d1d7bb 100644
--- a/testsuite/tests/runtime-errors/Makefile
+++ b/testsuite/tests/runtime-errors/Makefile
@@ -1,32 +1,55 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 
+.PHONY: default
 default: compile run
 
+.PHONY: compile
 compile:
 	@for f in *.ml; do \
-	  $(OCAMLC) -w a -o `basename $$f ml`bytecode $$f; \
-	  test -z "$(BYTECODE_ONLY)" && $(OCAMLOPT) -w a -o `basename $$f ml`native $$f || true; \
+	  F=`basename $$f .ml`; \
+	  rm -f $$F.bytecode $$F.native $$F.native.exe; \
+	  $(OCAMLC) -w a -o $$F.bytecode $$f; \
+	  if $(BYTECODE_ONLY); then : ; else \
+	    $(OCAMLOPT) -w a -o $$F.native$(EXE) $$f; \
+	  fi; \
 	done
-	@if [ ! `grep -c HAS_STACK_OVERFLOW_DETECTION ../../../config/s.h` ]; then \
-	  test -z "$(BYTECODE_ONLY)" && rm -f stackoverflow.byte stackoverflow.native || true; \
-	fi
+	@grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/config/s.h \
+	  || rm -f stackoverflow.native$(EXE)
 
+.PHONY: run
 run:
 	@ulimit -s 1024; \
-         for f in *.bytecode; do \
+	 for f in *.bytecode; do \
 	  printf " ... testing '$$f':"; \
-	  (./$$f > $$f.result 2>&1; true); \
-	  $(DIFF) $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
-	  if [ -z "$(BYTECODE_ONLY)" ]; then \
-	    printf " ... testing '`basename $$f bytecode`native':"; \
-	    (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \
-	    $(DIFF) `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+	  $(OCAMLRUN) ./$$f >$$f.result 2>&1 || true; \
+	  DIFF="$(DIFF)" sh $$f.checker \
+	  && echo " => passed" || echo " => failed"; \
+	  fn=`basename $$f bytecode`native; \
+	  if $(BYTECODE_ONLY) || [ ! -f "$${fn}$(EXE)" ] ; then : ; else \
+	    printf " ... testing '$$fn':"; \
+	    ./$${fn}$(EXE) >$$fn.result 2>&1 || true; \
+	    DIFF="$(DIFF)" sh $$fn.checker \
+	    && echo " => passed" || echo " => failed"; \
 	  fi; \
 	done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
-	@rm -f *.bytecode *.native *.result
+	@rm -f *.bytecode *.native *.native.exe *.result
 
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker
new file mode 100644
index 00000000..893d1efd
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker
@@ -0,0 +1,14 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result
+
diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index ab53b8b0..21fe04bd 100644
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rec f x =
   if not (x = 0 || x = 10000 || x = 20000)
   then 1 + f (x + 1)
diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.checker b/testsuite/tests/runtime-errors/stackoverflow.native.checker
new file mode 100644
index 00000000..ac12dd3f
--- /dev/null
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.checker
@@ -0,0 +1,14 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+$DIFF stackoverflow.native.reference stackoverflow.native.result
+
diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.checker b/testsuite/tests/runtime-errors/syserror.bytecode.checker
new file mode 100644
index 00000000..ed2d2095
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.bytecode.checker
@@ -0,0 +1,16 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null
+
+
+
diff --git a/testsuite/tests/runtime-errors/syserror.ml b/testsuite/tests/runtime-errors/syserror.ml
index 46f62ead..cf16ca0c 100644
--- a/testsuite/tests/runtime-errors/syserror.ml
+++ b/testsuite/tests/runtime-errors/syserror.ml
@@ -1 +1,13 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let channel = open_out "titi:/toto"
diff --git a/testsuite/tests/runtime-errors/syserror.native.checker b/testsuite/tests/runtime-errors/syserror.native.checker
new file mode 100644
index 00000000..5d8ed3c3
--- /dev/null
+++ b/testsuite/tests/runtime-errors/syserror.native.checker
@@ -0,0 +1,13 @@
+#########################################################################
+#                                                                       #
+#                                 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 Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+grep 'Fatal error: exception Sys_error' syserror.native.result >/dev/null
diff --git a/testsuite/tests/tool-lexyacc/Makefile b/testsuite/tests/tool-lexyacc/Makefile
index 3d7f49be..082db4dc 100644
--- a/testsuite/tests/tool-lexyacc/Makefile
+++ b/testsuite/tests/tool-lexyacc/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 MODULES=syntax gram_aux grammar scan_aux scanner lexgen output
 MAIN_MODULE=main
diff --git a/testsuite/tests/tool-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml
index 3f8efd95..255f58f3 100644
--- a/testsuite/tests/tool-lexyacc/gram_aux.ml
+++ b/testsuite/tests/tool-lexyacc/gram_aux.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: gram_aux.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Auxiliaries for the parser. *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
index 20602988..a1821367 100644
--- a/testsuite/tests/tool-lexyacc/grammar.mly
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: grammar.mly 12800 2012-07-30 18:59:07Z doligez $ */
-
 /* The grammar for lexer definitions */
 
 %{
diff --git a/testsuite/tests/tool-lexyacc/input b/testsuite/tests/tool-lexyacc/input
index 2485d39b..c0d78594 100644
--- a/testsuite/tests/tool-lexyacc/input
+++ b/testsuite/tests/tool-lexyacc/input
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: input 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* The lexical analyzer for lexer definitions. *)
 
 {
diff --git a/testsuite/tests/tool-lexyacc/input.ml b/testsuite/tests/tool-lexyacc/input.ml
deleted file mode 100644
index 002bf72c..00000000
--- a/testsuite/tests/tool-lexyacc/input.ml
+++ /dev/null
@@ -1,311 +0,0 @@
-
-open Syntax
-open Grammar
-open Scan_aux
-
-let rec action_43 lexbuf = (
- comment lexbuf )
-and action_42 lexbuf = (
- raise(Lexical_error "unterminated comment") )
-and action_41 lexbuf = (
- reset_string_buffer();
-      string lexbuf;
-      reset_string_buffer();
-      comment lexbuf )
-and action_40 lexbuf = (
- decr comment_depth;
-      if !comment_depth = 0 then () else comment lexbuf )
-and action_39 lexbuf = (
- incr comment_depth; comment lexbuf )
-and action_38 lexbuf = (
- raise(Lexical_error "bad character constant") )
-and action_37 lexbuf = (
- char_for_decimal_code lexbuf 1 )
-and action_36 lexbuf = (
- char_for_backslash (Lexing.lexeme_char lexbuf 1) )
-and action_35 lexbuf = (
- Lexing.lexeme_char lexbuf 0 )
-and action_34 lexbuf = (
- store_string_char(Lexing.lexeme_char lexbuf 0);
-      string lexbuf )
-and action_33 lexbuf = (
- raise(Lexical_error "unterminated string") )
-and action_32 lexbuf = (
- store_string_char(char_for_decimal_code lexbuf 1);
-      string lexbuf )
-and action_31 lexbuf = (
- store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
-      string lexbuf )
-and action_30 lexbuf = (
- string lexbuf )
-and action_29 lexbuf = (
- () )
-and action_28 lexbuf = (
- action lexbuf )
-and action_27 lexbuf = (
- raise (Lexical_error "unterminated action") )
-and action_26 lexbuf = (
- comment_depth := 1;
-      comment lexbuf;
-      action lexbuf )
-and action_25 lexbuf = (
- let _ = char lexbuf in action lexbuf )
-and action_24 lexbuf = (
- reset_string_buffer();
-      string lexbuf;
-      reset_string_buffer();
-      action lexbuf )
-and action_23 lexbuf = (
- decr brace_depth;
-      if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf )
-and action_22 lexbuf = (
- incr brace_depth;
-      action lexbuf )
-and action_21 lexbuf = (
- raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) )
-and action_20 lexbuf = (
- raise(Lexical_error "unterminated lexer definition") )
-and action_19 lexbuf = (
- Tdash )
-and action_18 lexbuf = (
- Tcaret )
-and action_17 lexbuf = (
- Trparen )
-and action_16 lexbuf = (
- Tlparen )
-and action_15 lexbuf = (
- Tplus )
-and action_14 lexbuf = (
- Tmaybe )
-and action_13 lexbuf = (
- Tstar )
-and action_12 lexbuf = (
- Trbracket )
-and action_11 lexbuf = (
- Tlbracket )
-and action_10 lexbuf = (
- Teof )
-and action_9 lexbuf = (
- Tunderscore )
-and action_8 lexbuf = (
- Tor )
-and action_7 lexbuf = (
- Tend )
-and action_6 lexbuf = (
- Tequal )
-and action_5 lexbuf = (
- let n1 = Lexing.lexeme_end lexbuf in
-        brace_depth := 1;
-        let n2 = action lexbuf in
-          Taction(Location(n1, n2)) )
-and action_4 lexbuf = (
- Tchar(char lexbuf) )
-and action_3 lexbuf = (
- reset_string_buffer();
-      string lexbuf;
-      Tstring(get_stored_string()) )
-and action_2 lexbuf = (
- match Lexing.lexeme lexbuf with
-        "rule" -> Trule
-      | "parse" -> Tparse
-      | "and" -> Tand
-      | "eof" -> Teof
-      | s -> Tident s )
-and action_1 lexbuf = (
- comment_depth := 1;
-      comment lexbuf;
-      main lexbuf )
-and action_0 lexbuf = (
- main lexbuf )
-and state_0 lexbuf =
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A' -> state_51 lexbuf
- |  ' '|'\013'|'\n'|'\t' -> state_40 lexbuf
- |  '|' -> action_8 lexbuf
- |  '{' -> action_5 lexbuf
- |  'e' -> state_56 lexbuf
- |  '_' -> state_55 lexbuf
- |  '^' -> action_18 lexbuf
- |  ']' -> action_12 lexbuf
- |  '[' -> action_11 lexbuf
- |  '?' -> action_14 lexbuf
- |  '=' -> action_6 lexbuf
- |  ';' -> state_48 lexbuf
- |  '-' -> action_19 lexbuf
- |  '+' -> action_15 lexbuf
- |  '*' -> action_13 lexbuf
- |  ')' -> action_17 lexbuf
- |  '(' -> state_43 lexbuf
- |  '\'' -> action_4 lexbuf
- |  '"' -> action_3 lexbuf
- |  '\000' -> action_20 lexbuf
- |  _ -> action_21 lexbuf
-and state_1 lexbuf =
-  match lexing.next_char lexbuf with
-    '}' -> action_23 lexbuf
- |  '{' -> action_22 lexbuf
- |  '(' -> state_34 lexbuf
- |  '\'' -> action_25 lexbuf
- |  '"' -> action_24 lexbuf
- |  '\000' -> action_27 lexbuf
- |  _ -> action_28 lexbuf
-and state_2 lexbuf =
-  match lexing.next_char lexbuf with
-    '\\' -> state_24 lexbuf
- |  '"' -> action_29 lexbuf
- |  '\000' -> action_33 lexbuf
- |  _ -> action_34 lexbuf
-and state_3 lexbuf =
-  match lexing.next_char lexbuf with
-    '\\' -> state_13 lexbuf
- |  '\000' -> lexing.backtrack lexbuf
- |  _ -> state_12 lexbuf
-and state_4 lexbuf =
-  match lexing.next_char lexbuf with
-    '*' -> state_9 lexbuf
- |  '(' -> state_8 lexbuf
- |  '"' -> action_41 lexbuf
- |  '\000' -> action_42 lexbuf
- |  _ -> action_43 lexbuf
-and state_8 lexbuf =
-  Lexing.set_backtrack lexbuf action_43;
-  match lexing.next_char lexbuf with
-    '*' -> action_39 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_9 lexbuf =
-  Lexing.set_backtrack lexbuf action_43;
-  match lexing.next_char lexbuf with
-    ')' -> action_40 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_12 lexbuf =
-  Lexing.set_backtrack lexbuf action_38;
-  match lexing.next_char lexbuf with
-    '\'' -> action_35 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_13 lexbuf =
-  Lexing.set_backtrack lexbuf action_38;
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_15 lexbuf
- |  't'|'r'|'n'|'b'|'\\'|'\'' -> state_14 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_14 lexbuf =
-  match lexing.next_char lexbuf with
-    '\'' -> action_36 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_15 lexbuf =
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_16 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_16 lexbuf =
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_17 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_17 lexbuf =
-  match lexing.next_char lexbuf with
-    '\'' -> action_37 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_24 lexbuf =
-  Lexing.set_backtrack lexbuf action_34;
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_27 lexbuf
- |  't'|'r'|'n'|'b'|'\\'|'"' -> action_31 lexbuf
- |  ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_25 lexbuf =
-  Lexing.set_backtrack lexbuf action_30;
-  match lexing.next_char lexbuf with
-    ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_27 lexbuf =
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_28 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_28 lexbuf =
-  match lexing.next_char lexbuf with
-    '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> action_32 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_34 lexbuf =
-  Lexing.set_backtrack lexbuf action_28;
-  match lexing.next_char lexbuf with
-    '*' -> action_26 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_40 lexbuf =
-  Lexing.set_backtrack lexbuf action_0;
-  match lexing.next_char lexbuf with
-    ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_43 lexbuf =
-  Lexing.set_backtrack lexbuf action_16;
-  match lexing.next_char lexbuf with
-    '*' -> action_1 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_48 lexbuf =
-  Lexing.set_backtrack lexbuf action_21;
-  match lexing.next_char lexbuf with
-    ';' -> action_7 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_51 lexbuf =
-  Lexing.set_backtrack lexbuf action_2;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  '_' -> state_60 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_55 lexbuf =
-  Lexing.set_backtrack lexbuf action_9;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_56 lexbuf =
-  Lexing.set_backtrack lexbuf action_2;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  'o' -> state_61 lexbuf
- |  '_' -> state_60 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_59 lexbuf =
-  Lexing.set_backtrack lexbuf action_2;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  '_' -> state_60 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_60 lexbuf =
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_61 lexbuf =
-  Lexing.set_backtrack lexbuf action_2;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  'f' -> state_62 lexbuf
- |  '_' -> state_60 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_62 lexbuf =
-  Lexing.set_backtrack lexbuf action_2;
-  match lexing.next_char lexbuf with
-    'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf
- |  '_' -> state_60 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and state_65 lexbuf =
-  Lexing.set_backtrack lexbuf action_0;
-  match lexing.next_char lexbuf with
-    ' '|'\013'|'\n'|'\t' -> state_65 lexbuf
- |  _ -> lexing.backtrack lexbuf
-and main lexbuf =
-  Lexing.init lexbuf;
-  state_0 lexbuf
-
-and action lexbuf =
-  Lexing.init lexbuf;
-  state_1 lexbuf
-
-and string lexbuf =
-  Lexing.init lexbuf;
-  state_2 lexbuf
-
-and char lexbuf =
-  Lexing.init lexbuf;
-  state_3 lexbuf
-
-and comment lexbuf =
-  Lexing.init lexbuf;
-  state_4 lexbuf
diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml
index 7b00ec92..1a599572 100644
--- a/testsuite/tests/tool-lexyacc/lexgen.ml
+++ b/testsuite/tests/tool-lexyacc/lexgen.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexgen.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Compiling a lexer definition *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml
index 1b879373..529eb12d 100644
--- a/testsuite/tests/tool-lexyacc/main.ml
+++ b/testsuite/tests/tool-lexyacc/main.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: main.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The lexer generator. Command-line parsing. *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml
index 44334b80..d8e85440 100644
--- a/testsuite/tests/tool-lexyacc/output.ml
+++ b/testsuite/tests/tool-lexyacc/output.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: output.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Generating a DFA as a set of mutually recursive functions *)
 
 open Syntax
diff --git a/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml
index 25b48b36..81168f33 100644
--- a/testsuite/tests/tool-lexyacc/scan_aux.ml
+++ b/testsuite/tests/tool-lexyacc/scan_aux.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scan_aux.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Auxiliaries for the lexical analyzer *)
 
 let brace_depth = ref 0
diff --git a/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll
index 2fc897db..7d71c685 100644
--- a/testsuite/tests/tool-lexyacc/scanner.mll
+++ b/testsuite/tests/tool-lexyacc/scanner.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scanner.mll 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* The lexical analyzer for lexer definitions. *)
 
 {
diff --git a/testsuite/tests/tool-lexyacc/syntax.ml b/testsuite/tests/tool-lexyacc/syntax.ml
index 9a1e275b..8f634466 100644
--- a/testsuite/tests/tool-lexyacc/syntax.ml
+++ b/testsuite/tests/tool-lexyacc/syntax.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: syntax.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The shallow abstract syntax *)
 
 type location =
diff --git a/testsuite/tests/tool-ocaml/Makefile b/testsuite/tests/tool-ocaml/Makefile
index 312fac5b..e1d92c88 100644
--- a/testsuite/tests/tool-ocaml/Makefile
+++ b/testsuite/tests/tool-ocaml/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 SHOULD_FAIL=t060-raise.ml
 
@@ -5,9 +17,11 @@ compile: lib.cmo
 	@for file in t*.ml; do \
 	  printf " ... testing '$$file'"; \
 	  if [ `echo $(SHOULD_FAIL) | grep $$file` ]; then \
-	    $(OCAML) -w a lib.cmo $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \
+	    $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+	    && echo " => failed" || echo " => passed"; \
 	  else \
-	    $(OCAML) -w a lib.cmo $$file 2> /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+	    $(OCAML) -w a lib.cmo $$file 2>/dev/null \
+	    && echo " => passed" || echo " => failed"; \
 	  fi; \
 	done
 
diff --git a/testsuite/tests/tool-ocaml/lib.ml b/testsuite/tests/tool-ocaml/lib.ml
index a5597283..9ab74271 100644
--- a/testsuite/tests/tool-ocaml/lib.ml
+++ b/testsuite/tests/tool-ocaml/lib.ml
@@ -1,5 +1,3 @@
-(* file $Id: lib.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 external raise : exn -> 'a = "%raise"
 
 external not : bool -> bool = "%boolnot"
@@ -42,5 +40,3 @@ external weak_set : 'a weak_t -> int -> 'a option -> unit = "caml_weak_set";;
 external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";;
 
 let x = 42;;
-
-(* eof $Id: lib.ml 11123 2011-07-20 09:17:07Z doligez $ *)
diff --git a/testsuite/tests/tool-ocaml/t301-object.ml b/testsuite/tests/tool-ocaml/t301-object.ml
index 11aadaa9..ac4a4e03 100644
--- a/testsuite/tests/tool-ocaml/t301-object.ml
+++ b/testsuite/tests/tool-ocaml/t301-object.ml
@@ -7,8 +7,6 @@ ocamlc -nostdlib -I ../../stdlib \
   t301-object.ml -o t301-object.byte
 
 ***)
-(* $Id: t301-object.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 
 class c = object (self)
   method pubmet = 1
@@ -25,5 +23,3 @@ let (x,y,z) = f () in
   if x <> 1 then raise Not_found;
   if y <> 2 then raise Not_found;
   if z <> 4 then raise Not_found;;
-
-(**** eof $Id: t301-object.ml 12800 2012-07-30 18:59:07Z doligez $ *)
diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile
index 2af4d347..cf454149 100644
--- a/testsuite/tests/tool-ocamldoc/Makefile
+++ b/testsuite/tests/tool-ocamldoc/Makefile
@@ -1,21 +1,44 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 CUSTOM_MODULE=odoc_test
-ADD_COMPFLAGS=-I +ocamldoc
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
 
-DIFF_OPT=--strip-trailing-cr
-#DIFF_OPT=-b
+.PHONY: default
+default:
+	@$(SET_LD_PATH) $(MAKE) run
 
+.PHONY: run
 run: $(CUSTOM_MODULE).cmo
 	@for file in t*.ml; do \
 	  printf " ... testing '$$file'"; \
-	  $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \
-	  $(DIFF) $(DIFF_OPT) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+	  F="`basename $$file .ml`"; \
+	  $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -g $(CUSTOM_MODULE).cmo \
+	              -o $$F.result $$file; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	done;
-	@$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true
-	@$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -html t*.ml 2>&1 \
+	  | grep -v test_types_display || true
+	@$(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex t*.ml 2>&1 \
+	  | grep -v test_types_display || true
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
 	@rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
 
diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
index aef0d33d..918cadc4 100644
--- a/testsuite/tests/tool-ocamldoc/odoc_test.ml
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -1,4 +1,5 @@
 (***********************************************************************)
+(*                                                                     *)
 (*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
@@ -9,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_test.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (** Custom generator to perform test on ocamldoc. *)
 
 open Odoc_info
diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile
index ea38ed37..e854696f 100644
--- a/testsuite/tests/typing-fstclassmod/Makefile
+++ b/testsuite/tests/typing-fstclassmod/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 #MODULES=
 MAIN_MODULE=fstclassmod
diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-gadts/Makefile
+++ b/testsuite/tests/typing-gadts/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
index 72a301c4..a894b22d 100644
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
@@ -148,7 +148,8 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
                                            ^^^^^^^^^^^^^^^^^
 Error: This pattern matches values of type a * a vlist
        but a pattern was expected which matches values of type
-         ex#46 = ex#47 * ex#48
+         a#5 = ex#34 * ex#35
+       Type a is not compatible with type ex#34 
 #                                                         type (_, _) ty =
     Int : (int, 'd) ty
   | String : (string, 'f) ty
diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
index 72a301c4..a894b22d 100644
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
@@ -148,7 +148,8 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, )
                                            ^^^^^^^^^^^^^^^^^
 Error: This pattern matches values of type a * a vlist
        but a pattern was expected which matches values of type
-         ex#46 = ex#47 * ex#48
+         a#5 = ex#34 * ex#35
+       Type a is not compatible with type ex#34 
 #                                                         type (_, _) ty =
     Int : (int, 'd) ty
   | String : (string, 'f) ty
diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
index cddfe460..364364a0 100644
--- a/testsuite/tests/typing-gadts/omega07.ml
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -10,7 +10,7 @@
 type ('a,'b) sum = Inl of 'a | Inr of 'b
 
 type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
 type _ nat =
   | NZ : zero nat
   | NS : 'a nat -> 'a succ nat
@@ -58,16 +58,16 @@ let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
 
 (* We do not have kinds, but we can encode them as predicates *)
 
-type tp
-type nd
-type (_,_) fk
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
 type _ shape =
   | Tp : tp shape
   | Nd : nd shape
   | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
 ;;
-type tt
-type ff
+type tt = TT
+type ff = FF
 type _ boolean =
   | BT : tt boolean
   | BF : ff boolean
@@ -151,6 +151,27 @@ let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
   | _ -> None
 ;;
 
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+  (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+  fun p1 p2 ->
+  match p1, p2 with
+  | PlusZ _, PlusZ _ -> Eq
+  | PlusS p1', PlusS p2' ->
+      let Eq = plus_func p1' p2' in Eq
+
+let rec plus_assoc : type a b c ab bc m n.
+  (a,b,ab) plus -> (ab,c,m) plus ->
+  (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+  match p1, p4 with
+  | PlusZ b, PlusZ bc ->
+      let Eq = plus_func p2 p3 in Eq
+  | PlusS p1', PlusS p4' ->
+      let PlusS p2' = p2 in
+      let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+
 (* 3.9 Computing Programs and Properties Simultaneously *)
 
 (* Plus and app1 are moved to section 2 *)
@@ -367,8 +388,8 @@ let delete x (Avl t) =
 
 (* Exercise 22: Red-black trees *)
 
-type red
-type black
+type red = RED
+type black = BLACK
 type (_,_) sub_tree =
   | Bleaf : (black, zero) sub_tree
   | Rnode :
@@ -537,8 +558,8 @@ let v4 = eval_term [] ex4
 
 (* 5.9/5.10 Language with binding *)
 
-type rnil
-type (_,_,_) rcons
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
 
 type _ is_row =
   | Rnil  : rnil is_row
@@ -687,14 +708,14 @@ let v2 = eval_checked env0 c2 ;;
 
 (* 5.12 Soundness *)
 
-type pexp
-type pval
+type pexp = PEXP
+type pval = PVAL
 type _ mode =
   | Pexp : pexp mode
   | Pval : pval mode
 
-type (_,_) tarr
-type tint
+type ('a,'b) tarr = TARR
+type tint = TINT
 
 type (_,_) rel =
   | IntR : (tint, int) rel
diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
index cf8b0b5b..75739ee3 100644
--- a/testsuite/tests/typing-gadts/omega07.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
@@ -1,7 +1,7 @@
 
 # * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
 type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
 type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
 #             type (_, _) seq =
     Snil : ('a, zero) seq
@@ -14,15 +14,15 @@ type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
 #   *                     type (_, _, _) app =
     App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
 val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
-# *                           type tp
-type nd
-type (_, _) fk
+# *                           type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
 type _ shape =
     Tp : tp shape
   | Nd : nd shape
   | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt
-type ff
+#           type tt = TT
+type ff = FF
 type _ boolean = BT : tt boolean | BF : ff boolean
 #                 type (_, _) path =
     Pnone : 'a -> (tp, 'a) path
@@ -54,6 +54,12 @@ val even4 : four even = EvenSS (EvenSS EvenZ)
 #                                 type (_, _) equal = Eq : ('a, 'a) equal
 val convert : ('a, 'b) equal -> 'a -> 'b = 
 val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+  
+val plus_assoc :
+  ('a, 'b, 'ab) plus ->
+  ('ab, 'c, 'm) plus ->
+  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
 #             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
 #   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
 #   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
@@ -96,8 +102,8 @@ type _ avl_del =
   | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
 val del : int -> 'n avl -> 'n avl_del = 
 #           val delete : int -> avl' -> avl' = 
-#                             type red
-type black
+#                             type red = RED
+type black = BLACK
 type (_, _) sub_tree =
     Bleaf : (black, zero) sub_tree
   | Rnode : (black, 'n) sub_tree * int *
@@ -169,8 +175,8 @@ val ex4 : int term =
   Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
    Const 3)
 val v4 : int = 6
-#                                             type rnil
-type (_, _, _) rcons
+#                                             type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
 type _ is_row =
     Rnil : rnil is_row
   | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
@@ -271,11 +277,11 @@ val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
    I)
 #           val eval_checked : 'a env -> 'a checked -> int = 
 #   val v2 : int = 6
-#                                             type pexp
-type pval
+#                                             type pexp = PEXP
+type pval = PVAL
 type _ mode = Pexp : pexp mode | Pval : pval mode
-type (_, _) tarr
-type tint
+type ('a, 'b) tarr = TARR
+type tint = TINT
 type (_, _) rel =
     IntR : (tint, int) rel
   | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference
index cf8b0b5b..75739ee3 100644
--- a/testsuite/tests/typing-gadts/omega07.ml.reference
+++ b/testsuite/tests/typing-gadts/omega07.ml.reference
@@ -1,7 +1,7 @@
 
 # * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
 type zero = Zero
-type _ succ
+type 'a succ = Succ of 'a
 type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
 #             type (_, _) seq =
     Snil : ('a, zero) seq
@@ -14,15 +14,15 @@ type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
 #   *                     type (_, _, _) app =
     App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
 val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = 
-# *                           type tp
-type nd
-type (_, _) fk
+# *                           type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
 type _ shape =
     Tp : tp shape
   | Nd : nd shape
   | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt
-type ff
+#           type tt = TT
+type ff = FF
 type _ boolean = BT : tt boolean | BF : ff boolean
 #                 type (_, _) path =
     Pnone : 'a -> (tp, 'a) path
@@ -54,6 +54,12 @@ val even4 : four even = EvenSS (EvenSS EvenZ)
 #                                 type (_, _) equal = Eq : ('a, 'a) equal
 val convert : ('a, 'b) equal -> 'a -> 'b = 
 val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = 
+#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+  
+val plus_assoc :
+  ('a, 'b, 'ab) plus ->
+  ('ab, 'c, 'm) plus ->
+  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = 
 #             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = 
 #   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
 #   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = 
@@ -96,8 +102,8 @@ type _ avl_del =
   | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
 val del : int -> 'n avl -> 'n avl_del = 
 #           val delete : int -> avl' -> avl' = 
-#                             type red
-type black
+#                             type red = RED
+type black = BLACK
 type (_, _) sub_tree =
     Bleaf : (black, zero) sub_tree
   | Rnode : (black, 'n) sub_tree * int *
@@ -169,8 +175,8 @@ val ex4 : int term =
   Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
    Const 3)
 val v4 : int = 6
-#                                             type rnil
-type (_, _, _) rcons
+#                                             type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
 type _ is_row =
     Rnil : rnil is_row
   | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
@@ -271,11 +277,11 @@ val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
    I)
 #           val eval_checked : 'a env -> 'a checked -> int = 
 #   val v2 : int = 6
-#                                             type pexp
-type pval
+#                                             type pexp = PEXP
+type pval = PVAL
 type _ mode = Pexp : pexp mode | Pval : pval mode
-type (_, _) tarr
-type tint
+type ('a, 'b) tarr = TARR
+type tint = TINT
 type (_, _) rel =
     IntR : (tint, int) rel
   | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
diff --git a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
index f1e142aa..fabdb17c 100644
--- a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
@@ -16,13 +16,12 @@ type _ inline_t =
 #           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
 #                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
 #       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 272-279:
-      | (Kind Maylink, Ast_Link lnk)    -> Link lnk
-              ^^^^^^^
-Error: This pattern matches values of type inkind linkp
-       but a pattern was expected which matches values of type
-         ([< inkind ] as 'a) linkp
-       Type inkind = [ `Link | `Nonlink ] is not compatible with type
-         'a = [< `Link | `Nonlink ] 
+#                         Characters 184-192:
+      | (Kind _, Ast_Text txt)    -> Text txt
+                                     ^^^^^^^^
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+       but an expression was expected of type a inline_t
+       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+         a = [< `Link | `Nonlink ] 
        Types for tag `Nonlink are incompatible
 # 
diff --git a/testsuite/tests/typing-gadts/pr5689.ml.reference b/testsuite/tests/typing-gadts/pr5689.ml.reference
index f1e142aa..fabdb17c 100644
--- a/testsuite/tests/typing-gadts/pr5689.ml.reference
+++ b/testsuite/tests/typing-gadts/pr5689.ml.reference
@@ -16,13 +16,12 @@ type _ inline_t =
 #           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
 #                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = 
 #       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 272-279:
-      | (Kind Maylink, Ast_Link lnk)    -> Link lnk
-              ^^^^^^^
-Error: This pattern matches values of type inkind linkp
-       but a pattern was expected which matches values of type
-         ([< inkind ] as 'a) linkp
-       Type inkind = [ `Link | `Nonlink ] is not compatible with type
-         'a = [< `Link | `Nonlink ] 
+#                         Characters 184-192:
+      | (Kind _, Ast_Text txt)    -> Text txt
+                                     ^^^^^^^^
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+       but an expression was expected of type a inline_t
+       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+         a = [< `Link | `Nonlink ] 
        Types for tag `Nonlink are incompatible
 # 
diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml
new file mode 100644
index 00000000..fdfa7ebf
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5785.ml
@@ -0,0 +1,10 @@
+module Add (T : sig type two end) =
+struct
+  type _ t =
+  | One : [`One] t
+  | Two : T.two t
+
+  let add (type a) : a t * a t -> string = function
+    | One, One -> "two"
+    | Two, Two -> "four"
+end;;
diff --git a/testsuite/tests/typing-gadts/pr5785.ml.reference b/testsuite/tests/typing-gadts/pr5785.ml.reference
new file mode 100644
index 00000000..0a1fb774
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5785.ml.reference
@@ -0,0 +1,15 @@
+
+#                   Characters 137-194:
+  ...........................................function
+      | One, One -> "two"
+      | Two, Two -> "four"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Two, One)
+module Add :
+  functor (T : sig type two end) ->
+    sig
+      type _ t = One : [ `One ] t | Two : T.two t
+      val add : 'a t * 'a t -> string
+    end
+# 
diff --git a/testsuite/tests/typing-gadts/pr5848.ml b/testsuite/tests/typing-gadts/pr5848.ml
new file mode 100644
index 00000000..c07e30c9
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5848.ml
@@ -0,0 +1,14 @@
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+  match B.f x 4 with
+  | Eq -> 5
+;;
diff --git a/testsuite/tests/typing-gadts/pr5848.ml.reference b/testsuite/tests/typing-gadts/pr5848.ml.reference
new file mode 100644
index 00000000..577a6dc4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5848.ml.reference
@@ -0,0 +1,8 @@
+
+#                 module B :
+  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
+#         Characters 65-67:
+    | Eq -> 5
+      ^^
+Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+# 
diff --git a/testsuite/tests/typing-gadts/pr5906.ml b/testsuite/tests/typing-gadts/pr5906.ml
new file mode 100644
index 00000000..7b53c5c9
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5906.ml
@@ -0,0 +1,17 @@
+type _ constant =
+  | Int: int -> int constant
+  | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+  | Eq: ('a, 'a, bool) binop
+  | Leq: ('a, 'a, bool) binop
+  | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant) (y:b constant) : c constant =
+  match bop, x, y with
+  | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+  | Leq, Int x, Int y -> Bool (x <= y)
+  | Leq, Bool x, Bool y -> Bool (x <= y)
+  | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
diff --git a/testsuite/tests/typing-gadts/pr5906.ml.reference b/testsuite/tests/typing-gadts/pr5906.ml.reference
new file mode 100644
index 00000000..85c13297
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5906.ml.reference
@@ -0,0 +1,5 @@
+
+#                                   
+Characters 524-524:
+  Error: Syntax error
+# 
diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml
new file mode 100644
index 00000000..8ba45d2d
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5948.ml
@@ -0,0 +1,30 @@
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly = 
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function 
+    `TagA i -> i
+  | `TagB -> 4
+;;
+
+type _ wrapPoly = 
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+  fun w -> 
+    match w with
+    | WrapPoly ATag -> intA
+    | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+
+let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
diff --git a/testsuite/tests/typing-gadts/pr5948.ml.reference b/testsuite/tests/typing-gadts/pr5948.ml.reference
new file mode 100644
index 00000000..7d774212
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5948.ml.reference
@@ -0,0 +1,22 @@
+
+# type tag = [ `TagA | `TagB | `TagC ]
+#           type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int ] poly
+#       val intA : [< `TagA of 'a ] -> 'a = 
+val intB : [< `TagB ] -> int = 
+#         val intAorB : [< `TagA of int | `TagB ] -> int = 
+#       type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
+#             Characters 103-107:
+      | WrapPoly ATag -> intA
+                         ^^^^
+Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
+       but an expression was expected of type a -> int
+       Type 'a is not compatible with type a = [< `TagA of int | `TagB ] 
+       The first variant type does not allow tag(s) `TagB
+#     Characters 10-18:
+  let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+           ^^^^^^^^
+Error: Unbound value example6
+# 
diff --git a/testsuite/tests/typing-gadts/pr5981.ml b/testsuite/tests/typing-gadts/pr5981.ml
new file mode 100644
index 00000000..f93b4e36
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5981.ml
@@ -0,0 +1,22 @@
+module F(S : sig type 'a t end) = struct
+  type _ ab =
+      A : int S.t ab
+    | B : float S.t ab
+
+  let f : int S.t ab -> float S.t ab -> string =
+    fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+    | A, B -> "f A B"
+end;;
+
+module F(S : sig type 'a t end) = struct
+  type a = int * int
+  type b = int -> int
+
+  type _ ab =
+      A : a S.t ab
+    | B : b S.t ab
+
+  let f : a S.t ab -> b S.t ab -> string =
+    fun l r -> match l, r with
+    | A, B -> "f A B"
+end;;
diff --git a/testsuite/tests/typing-gadts/pr5981.ml.reference b/testsuite/tests/typing-gadts/pr5981.ml.reference
new file mode 100644
index 00000000..3a2d7b16
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5981.ml.reference
@@ -0,0 +1,28 @@
+
+#                 Characters 196-233:
+  ...............................................match l, r with
+      | A, B -> "f A B"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type _ ab = A : int S.t ab | B : float S.t ab
+      val f : int S.t ab -> float S.t ab -> string
+    end
+#                         Characters 197-234:
+  ...............match l, r with
+      | A, B -> "f A B"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type a = int * int
+      type b = int -> int
+      type _ ab = A : a S.t ab | B : b S.t ab
+      val f : a S.t ab -> b S.t ab -> string
+    end
+# 
diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml
new file mode 100644
index 00000000..fdc66e82
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5985.ml
@@ -0,0 +1,94 @@
+(* Report from Jeremy Yallop *)
+module F (S : sig type 'a s end) = struct
+  include S
+  type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+(*
+module M = F (struct type 'a s = int end) ;;
+let M.T x = M.T 3 in x = true;;
+*)
+
+(* Fix it using #-annotations *)
+module F (S : sig type #'a s end) = struct
+  include S
+  type _ t = T : 'a -> 'a s t
+end;; (* syntax error *)
+(*
+module M = F (struct type 'a s = int end) ;; (* fail *)
+module M = F (struct type 'a s = new int end) ;; (* ok *)
+let M.T x = M.T 3 in x = true;; (* fail *)
+let M.T x = M.T 3 in x = 3;; (* ok *)
+*)
+
+(* Another version using OCaml 2.00 objects *)
+module F(T:sig type 'a t end) = struct
+  class ['a] c x =
+    object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
+end;; (* fail *)
+
+(* It is not OK to allow modules exported by other compilation units *)
+type (_,_) eq = Eq : ('a,'a) eq;;
+let eq = Obj.magic Eq;;
+(* pretend that Queue.t is not injective *)
+let eq : ('a Queue.t, 'b Queue.t) eq = eq;;
+type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+(*
+let castT (type a) (type b) (x : a t) (e: (a, b) eq) : b t =
+  let Eq = e in (x : b t);;
+let T (x : bool) = castT (T 3) eq;; (* we found a contradiction *)
+*)
+
+(* The following signature should not be accepted *)
+module type S = sig
+  type 'a s
+  type _ t = T : 'a -> 'a s t
+end;; (* fail *)
+(* Otherwise we can write the following *)
+module rec M : (S with type 'a s = unit) = M;;
+(* For the above reason, we cannot allow the abstract declaration
+   of s and the definition of t to be in the same module, as
+   we could create the signature using [module type of ...] *)
+
+
+(* Another problem with variance *)
+module M = struct type 'a t = 'a -> unit end;;
+module F(X:sig type #'a t end) =
+  struct type +'a s = S of 'b constraint 'a = 'b X.t end;; (* fail *)
+(*
+module N = F(M);;
+let o = N.S (object end);;
+let N.S o' = (o :>  M.t N.s);; (* unsound! *)
+*)
+
+(* And yet another *)
+type 'a q = Q;;
+type +'a t = 'b constraint 'a = 'b q;;
+(* shoud fail: we do not know for sure the variance of Queue.t *)
+
+type +'a t = T of 'a;;
+type +'a s = 'b constraint 'a = 'b t;; (* ok *)
+type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+type +'a u = 'a t;;
+type 'a t = T of ('a -> 'a);;
+type -'a s = 'b constraint 'a = 'b t;; (* ok *)
+type +'a s = 'b constraint 'a = 'b q t;; (* ok *)
+type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+
+
+(* the problem from lablgtk2 *)
+
+module Gobject = struct
+  type -'a obj
+end
+open Gobject;;
+
+class virtual ['a] item_container =
+ object
+   constraint 'a = < as_item : [>`widget] obj; .. >
+   method virtual add : 'a -> unit
+ end;;
+
+
+(* Another variance anomaly, should not expand t in g before checking *)
+type +'a t = unit constraint 'a = 'b list;;
+type _ g = G : 'a -> 'a t g;; (* fail *)
diff --git a/testsuite/tests/typing-gadts/pr5985.ml.reference b/testsuite/tests/typing-gadts/pr5985.ml.reference
new file mode 100644
index 00000000..fc7d792a
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5985.ml.reference
@@ -0,0 +1,75 @@
+
+#         Characters 92-115:
+    type _ t = T : 'a -> 'a s t
+        ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+# * * *             Characters 131-134:
+  module F (S : sig type #'a s end) = struct
+                ^^^
+Syntax error: 'end' expected, the highlighted 'sig' might be unmatched
+# * * * * *             Characters 296-374:
+  ........['a] c x =
+      object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+#     type (_, _) eq = Eq : ('a, 'a) eq
+# val eq : 'a = 
+#   val eq : ('a Queue.t, 'b Queue.t) eq = Eq
+# Characters 4-33:
+  type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+# * * * *             Characters 254-277:
+    type _ t = T : 'a -> 'a s t
+        ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+#   Characters 59-60:
+  module rec M : (S with type 'a s = unit) = M;;
+                  ^
+Error: Unbound module type S
+# * *         module M : sig type 'a t = 'a -> unit end
+#   Characters 11-14:
+  module F(X:sig type #'a t end) =
+             ^^^
+Syntax error: 'end' expected, the highlighted 'sig' might be unmatched
+# * * * *       type 'a q = Q
+# Characters 5-36:
+  type +'a t = 'b constraint 'a = 'b q;;
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+#     type 'a t = T of 'a
+# type +'a s = 'b constraint 'a = 'b t
+# Characters 5-36:
+  type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+       is not reflected by its occurrence in type parameters.
+       It was expected to be contravariant, but it is covariant.
+# type 'a u = 'a t
+# type 'a t = T of ('a -> 'a)
+# type -'a s = 'b constraint 'a = 'b t
+# type +'a s = 'b constraint 'a = 'b q t
+# Characters 5-38:
+  type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+#               module Gobject : sig type -'a obj end
+#           class virtual ['a] item_container :
+  object
+    constraint 'a = < as_item : [> `widget ] Gobject.obj; .. >
+    method virtual add : 'a -> unit
+  end
+#       type +'a t = unit constraint 'a = 'b list
+# Characters 4-27:
+  type _ g = G : 'a -> 'a t g;; (* fail *)
+      ^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+# 
diff --git a/testsuite/tests/typing-gadts/pr5989.ml b/testsuite/tests/typing-gadts/pr5989.ml
new file mode 100644
index 00000000..392df7f2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5989.ml
@@ -0,0 +1,35 @@
+type (_, _) t =
+    Any : ('a, 'b) t
+  | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+  type s = private [> `A]
+  val eq : (s, [`A | `B]) t
+end =
+struct
+  type s = [`A | `B]
+  let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+  | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+
+module N :
+sig
+  type s = private < a : int; .. >
+  val eq : (s, ) t
+end =
+struct
+  type s = 
+  let eq = Eq
+end
+;;
+
+let f : (N.s, ) t -> string = function
+  | Any -> "Any"
+;;
diff --git a/testsuite/tests/typing-gadts/pr5989.ml.reference b/testsuite/tests/typing-gadts/pr5989.ml.reference
new file mode 100644
index 00000000..f881c9b8
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5989.ml.reference
@@ -0,0 +1,24 @@
+
+#       type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
+#                   module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
+#       Characters 40-65:
+  .......................................function
+    | Any -> "Any"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+val f : (M.s, [ `A | `B ]) t -> string = 
+#   Exception: Match_failure ("//toplevel//", 14, 39).
+#                     module N :
+  sig
+    type s = private < a : int; .. >
+    val eq : (s, < a : int; b : bool >) t
+  end
+#       Characters 50-75:
+  .................................................function
+    | Any -> "Any"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+val f : (N.s, < a : int; b : bool >) t -> string = 
+# 
diff --git a/testsuite/tests/typing-gadts/pr5997.ml b/testsuite/tests/typing-gadts/pr5997.ml
new file mode 100644
index 00000000..81eec137
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5997.ml
@@ -0,0 +1,28 @@
+type (_, _) comp =
+  | Eq : ('a, 'a) comp
+  | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+  type t = T
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+  type t = {x : int}
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
diff --git a/testsuite/tests/typing-gadts/pr5997.ml.reference b/testsuite/tests/typing-gadts/pr5997.ml.reference
new file mode 100644
index 00000000..65af9f3b
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5997.ml.reference
@@ -0,0 +1,21 @@
+
+#       type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
+#   module U : sig type t = T end
+#               module M : sig type t = T val comp : (U.t, t) comp end
+#   Characters 1-34:
+  match M.comp with | Diff -> false;;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+Exception: Match_failure ("//toplevel//", 13, 0).
+#   module U : sig type t = { x : int; } end
+#               module M : sig type t = { x : int; } val comp : (U.t, t) comp end
+#   Characters 1-34:
+  match M.comp with | Diff -> false;;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Eq
+Exception: Match_failure ("//toplevel//", 22, 0).
+# 
diff --git a/testsuite/tests/typing-gadts/pr6158.ml b/testsuite/tests/typing-gadts/pr6158.ml
new file mode 100644
index 00000000..752380cb
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6158.ml
@@ -0,0 +1,9 @@
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
diff --git a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
new file mode 100644
index 00000000..e7d54587
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
@@ -0,0 +1,19 @@
+
+#       type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+#   Characters 46-50:
+  let f : (int s, int t) eq -> unit = function Refl -> ();;
+                                               ^^^^
+Error: This pattern matches values of type (int s, int s) eq
+       but a pattern was expected which matches values of type
+         (int s, int t) eq
+       Type int s is not compatible with type int t 
+#     Characters 120-124:
+  struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+                                                        ^^^^
+Error: This pattern matches values of type (ex#0 S.s, ex#1 S.t) eq
+       but a pattern was expected which matches values of type
+         (ex#0 S.s, ex#0 S.t) eq
+       The type constructor ex#0 would escape its scope
+# 
diff --git a/testsuite/tests/typing-gadts/pr6158.ml.reference b/testsuite/tests/typing-gadts/pr6158.ml.reference
new file mode 100644
index 00000000..c7d5c1ec
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6158.ml.reference
@@ -0,0 +1,15 @@
+
+#       type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+#   Characters 46-50:
+  let f : (int s, int t) eq -> unit = function Refl -> ();;
+                                               ^^^^
+Error: This pattern matches values of type (int s, int s) eq
+       but a pattern was expected which matches values of type
+         (int s, int t) eq
+       Type int s is not compatible with type int t 
+#     module M :
+  functor (S : sig type 'a t = T of 'a type 'a s = T of 'a end) ->
+    sig val f : (a#0 S.s, a#0 S.t) eq -> unit end
+# 
diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml
new file mode 100644
index 00000000..e9646196
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6163.ml
@@ -0,0 +1,14 @@
+type _ nat = 
+    Zero : [`Zero] nat
+  | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+  | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+  match x with
+  | Succ Zero -> "1"
+  | Succ (Succ Zero) -> "2"
+  | Succ (Succ (Succ Zero)) -> "3"
+  | Succ (Succ (Succ (Succ Zero))) -> "4"
+;;
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
new file mode 100644
index 00000000..0b771dc7
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
@@ -0,0 +1,18 @@
+
+#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+# type 'a pre_nat = [ `Succ of 'a | `Zero ]
+#   type aux =
+    Aux :
+      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
+      aux
+#               Characters 19-157:
+  ..match x with
+    | Succ Zero -> "1"
+    | Succ (Succ Zero) -> "2"
+    | Succ (Succ (Succ Zero)) -> "3"
+    | Succ (Succ (Succ (Succ Zero))) -> "4"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Succ (Succ (Succ (Succ (Succ _))))
+val f : aux -> string = 
+# 
diff --git a/testsuite/tests/typing-gadts/pr6163.ml.reference b/testsuite/tests/typing-gadts/pr6163.ml.reference
new file mode 100644
index 00000000..0b771dc7
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6163.ml.reference
@@ -0,0 +1,18 @@
+
+#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+# type 'a pre_nat = [ `Succ of 'a | `Zero ]
+#   type aux =
+    Aux :
+      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
+      aux
+#               Characters 19-157:
+  ..match x with
+    | Succ Zero -> "1"
+    | Succ (Succ Zero) -> "2"
+    | Succ (Succ (Succ Zero)) -> "3"
+    | Succ (Succ (Succ (Succ Zero))) -> "4"
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Succ (Succ (Succ (Succ (Succ _))))
+val f : aux -> string = 
+# 
diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
index 3ba7cc8b..a8215290 100644
--- a/testsuite/tests/typing-gadts/test.ml
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -512,3 +512,28 @@ let f : type a. a ty -> a =
 let g : type a. a ty -> a =
   let () = () in
   fun x -> match x with Int y -> y;;
+
+(* Printing of anonymous variables *)
+
+module M = struct type _ t = int end;;
+module M = struct type _ t = T : int t end;;
+module N = M;;
+
+(* Principality *)
+
+(* adding a useless equation should not break inference *)
+let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
+  let Eq = ab in
+  let x =
+    let Eq = aint in
+    if true then a else b
+  in ignore x
+;; (* ok *)
+
+let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
+  let Eq = ab in
+  let x =
+    let Eq = bint in
+    if true then a else b
+  in ignore x
+;; (* ok *)
diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
index b5dcb790..551f9cb2 100644
--- a/testsuite/tests/typing-gadts/test.ml.principal.reference
+++ b/testsuite/tests/typing-gadts/test.ml.principal.reference
@@ -50,9 +50,9 @@ module Nonexhaustive :
 #               Characters 118-119:
       let eval (D x) = x
                        ^
-Error: This expression has type ex#16 t
-       but an expression was expected of type ex#16 t
-       The type constructor ex#16 would escape its scope
+Error: This expression has type a#2 t but an expression was expected of type
+         a#2 t
+       The type constructor a#2 would escape its scope
 #                       Characters 174-175:
             C ->
             ^
@@ -62,11 +62,12 @@ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
              ^^^^^^^^
 Error: This pattern matches values of type int t
        but a pattern was expected which matches values of type s t
-#                         Characters 224-237:
-          | `A, BoolLit _ -> ()
-            ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
-       but a pattern was expected which matches values of type 'a * int t
+       Type int is not compatible with type s 
+#                         module Polymorphic_variants :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val eval : [ `A ] * 's t -> unit
+  end
 #                                 Characters 299-300:
       | BoolLit b -> b
                      ^
@@ -274,6 +275,7 @@ val f : 'a ty -> 'a t -> int = 
                    ^^
 Error: This expression has type (a, a) eq
        but an expression was expected of type (a, b) eq
+       Type a is not compatible with type b 
 #       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
 #       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
 #                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
@@ -286,24 +288,30 @@ type _ int_bar = IB_constr : < bar : int; .. > int_bar
      ^
 Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < foo : int >
-       Type ex#20 = < bar : int; .. > is not compatible with type <  > 
+       Type ex#17 = < bar : int; .. > is not compatible with type <  > 
        The second object type has no method bar
 #         Characters 98-99:
     (x:)
      ^
 Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < bar : int; foo : int >
-       Type ex#22 = < bar : int; .. > is not compatible with type
+       Type ex#19 = < bar : int; .. > is not compatible with type
          < bar : int > 
+       The first object type has an abstract row, it cannot be closed
 #         Characters 98-99:
     (x:)
      ^
 Error: This expression has type < bar : int; foo : int; .. > as 'a
        but an expression was expected of type 'a
-       The type constructor ex#25 would escape its scope
+       The type constructor ex#22 would escape its scope
 #         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
 #         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
 #       type 'a ty = Int : int -> int ty
 #     val f : 'a ty -> 'a = 
 #       val g : 'a ty -> 'a = 
+#       module M : sig type _ t = int end
+# module M : sig type _ t = T : int t end
+# module N : sig type 'a t = 'a M.t = T : int t end
+#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
+#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
 # 
diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
index 5406ed2a..fc62f5d5 100644
--- a/testsuite/tests/typing-gadts/test.ml.reference
+++ b/testsuite/tests/typing-gadts/test.ml.reference
@@ -50,9 +50,9 @@ module Nonexhaustive :
 #               Characters 118-119:
       let eval (D x) = x
                        ^
-Error: This expression has type ex#16 t
-       but an expression was expected of type ex#16 t
-       The type constructor ex#16 would escape its scope
+Error: This expression has type a#2 t but an expression was expected of type
+         a#2 t
+       The type constructor a#2 would escape its scope
 #                       Characters 174-175:
             C ->
             ^
@@ -62,11 +62,12 @@ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
              ^^^^^^^^
 Error: This pattern matches values of type int t
        but a pattern was expected which matches values of type s t
-#                         Characters 224-237:
-          | `A, BoolLit _ -> ()
-            ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
-       but a pattern was expected which matches values of type 'a * int t
+       Type int is not compatible with type s 
+#                         module Polymorphic_variants :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val eval : [ `A ] * 's t -> unit
+  end
 #                                 module Propagation :
   sig
     type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
@@ -75,8 +76,7 @@ Error: This pattern matches values of type ([? `A ] as 'a) * bool t
 #             Characters 87-88:
     let f = function A -> 1 | B -> 2
                               ^
-Error: This pattern matches values of type b
-       but a pattern was expected which matches values of type a
+Error: The variant type a has no constructor B
 #   type _ t = Int : int t
 #   val ky : 'a -> 'a -> 'a = 
 #       val test : 'a t -> 'a = 
@@ -261,6 +261,7 @@ val f : 'a ty -> 'a t -> int = 
                    ^^
 Error: This expression has type (a, a) eq
        but an expression was expected of type (a, b) eq
+       Type a is not compatible with type b 
 #       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = 
 #       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = 
 #                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
@@ -273,24 +274,30 @@ type _ int_bar = IB_constr : < bar : int; .. > int_bar
      ^
 Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < foo : int >
-       Type ex#20 = < bar : int; .. > is not compatible with type <  > 
+       Type ex#17 = < bar : int; .. > is not compatible with type <  > 
        The second object type has no method bar
 #         Characters 98-99:
     (x:)
      ^
 Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < bar : int; foo : int >
-       Type ex#22 = < bar : int; .. > is not compatible with type
+       Type ex#19 = < bar : int; .. > is not compatible with type
          < bar : int > 
+       The first object type has an abstract row, it cannot be closed
 #         Characters 98-99:
     (x:)
      ^
 Error: This expression has type < bar : int; foo : int; .. > as 'a
        but an expression was expected of type 'a
-       The type constructor ex#25 would escape its scope
+       The type constructor ex#22 would escape its scope
 #         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = 
 #         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = 
 #       type 'a ty = Int : int -> int ty
 #     val f : 'a ty -> 'a = 
 #       val g : 'a ty -> 'a = 
+#       module M : sig type _ t = int end
+# module M : sig type _ t = T : int t end
+# module N : sig type 'a t = 'a M.t = T : int t end
+#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = 
+#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = 
 # 
diff --git a/testsuite/tests/typing-implicit_unpack/Makefile b/testsuite/tests/typing-implicit_unpack/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-implicit_unpack/Makefile
+++ b/testsuite/tests/typing-implicit_unpack/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-labels/Makefile b/testsuite/tests/typing-labels/Makefile
index 4ba0bffc..299656b2 100644
--- a/testsuite/tests/typing-labels/Makefile
+++ b/testsuite/tests/typing-labels/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-labels/mixin.ml b/testsuite/tests/typing-labels/mixin.ml
index 68233726..5ca686a1 100644
--- a/testsuite/tests/typing-labels/mixin.ml
+++ b/testsuite/tests/typing-labels/mixin.ml
@@ -1,5 +1,3 @@
-(* $Id: mixin.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 open StdLabels
 open MoreLabels
 
diff --git a/testsuite/tests/typing-labels/mixin2.ml b/testsuite/tests/typing-labels/mixin2.ml
index b10b8a03..8a5498fa 100644
--- a/testsuite/tests/typing-labels/mixin2.ml
+++ b/testsuite/tests/typing-labels/mixin2.ml
@@ -1,5 +1,3 @@
-(* $Id: mixin2.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 (* Full fledge version, using objects to structure code *)
 
 open StdLabels
diff --git a/testsuite/tests/typing-labels/mixin3.ml b/testsuite/tests/typing-labels/mixin3.ml
index b6d15b90..0b9db242 100644
--- a/testsuite/tests/typing-labels/mixin3.ml
+++ b/testsuite/tests/typing-labels/mixin3.ml
@@ -1,5 +1,3 @@
-(* $Id: mixin3.ml 11123 2011-07-20 09:17:07Z doligez $ *)
-
 (* Full fledge version, using objects to structure code *)
 
 open StdLabels
diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-misc/Makefile
+++ b/testsuite/tests/typing-misc/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml
new file mode 100644
index 00000000..b0f0229a
--- /dev/null
+++ b/testsuite/tests/typing-misc/labels.ml
@@ -0,0 +1,4 @@
+(* PR#5835 *)
+
+let f ~x = x + 1;;
+f ?x:0;;
diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference
new file mode 100644
index 00000000..b76dcddc
--- /dev/null
+++ b/testsuite/tests/typing-misc/labels.ml.principal.reference
@@ -0,0 +1,8 @@
+
+#     val f : x:int -> int = 
+# Characters 5-6:
+  f ?x:0;;
+       ^
+Warning 43: the label x is not optional.
+- : int = 1
+# 
diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference
new file mode 100644
index 00000000..b76dcddc
--- /dev/null
+++ b/testsuite/tests/typing-misc/labels.ml.reference
@@ -0,0 +1,8 @@
+
+#     val f : x:int -> int = 
+# Characters 5-6:
+  f ?x:0;;
+       ^
+Warning 43: the label x is not optional.
+- : int = 1
+# 
diff --git a/testsuite/tests/typing-misc/occur_check.ml b/testsuite/tests/typing-misc/occur_check.ml
new file mode 100644
index 00000000..5509b6f5
--- /dev/null
+++ b/testsuite/tests/typing-misc/occur_check.ml
@@ -0,0 +1,5 @@
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
diff --git a/testsuite/tests/typing-misc/occur_check.ml.reference b/testsuite/tests/typing-misc/occur_check.ml.reference
new file mode 100644
index 00000000..865c7d64
--- /dev/null
+++ b/testsuite/tests/typing-misc/occur_check.ml.reference
@@ -0,0 +1,15 @@
+
+#     type 'a t = 'a
+# Characters 42-43:
+  let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+                                            ^
+Error: This expression has type 'a list
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a list
+# Characters 42-43:
+  let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+                                            ^
+Error: This expression has type 'a * 'b
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a * 'b
+# 
diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
new file mode 100644
index 00000000..00dacf75
--- /dev/null
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -0,0 +1,7 @@
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
new file mode 100644
index 00000000..bc0741ab
--- /dev/null
+++ b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
@@ -0,0 +1,32 @@
+
+# type ab = [ `A | `B ]
+# Characters 32-35:
+  let f (x : [`A]) = match x with #ab -> 1;;
+                                  ^^^
+Error: This pattern matches values of type [? `A | `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+# Characters 31-34:
+  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+                                 ^^^
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+# Characters 34-36:
+  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+                                    ^^
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+#   Characters 50-52:
+  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+                                                   ^^
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = 
+# Characters 47-49:
+  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+                                                 ^^
+Error: This pattern matches values of type [? `C ]
+       but a pattern was expected which matches values of type [ `A | `B ]
+       The second variant type does not allow tag(s) `C
+# 
diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference
new file mode 100644
index 00000000..27c4cd43
--- /dev/null
+++ b/testsuite/tests/typing-misc/polyvars.ml.reference
@@ -0,0 +1,32 @@
+
+# type ab = [ `A | `B ]
+# Characters 32-35:
+  let f (x : [`A]) = match x with #ab -> 1;;
+                                  ^^^
+Error: This pattern matches values of type [? `A | `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+# Characters 31-34:
+  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+                                 ^^^
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+# Characters 34-36:
+  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+                                    ^^
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+#   Characters 50-52:
+  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+                                                   ^^
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = 
+# Characters 47-49:
+  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+                                                 ^^
+Error: This pattern matches values of type [? `C ]
+       but a pattern was expected which matches values of type [ `A | `B ]
+       The second variant type does not allow tag(s) `C
+# 
diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
index 36fa5ec7..ae296cf1 100644
--- a/testsuite/tests/typing-misc/records.ml
+++ b/testsuite/tests/typing-misc/records.ml
@@ -10,3 +10,29 @@ fun {x=3;z=2} -> ();;
 type u = private {mutable u:int};;
 {u=3};;
 fun x -> x.u <- 3;;
+
+(* Punning and abbreviations *)
+module M = struct
+  type t = {x: int; y: int}
+end;;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
diff --git a/testsuite/tests/typing-misc/records.ml.principal.reference b/testsuite/tests/typing-misc/records.ml.principal.reference
new file mode 100644
index 00000000..f084d039
--- /dev/null
+++ b/testsuite/tests/typing-misc/records.ml.principal.reference
@@ -0,0 +1,54 @@
+
+#   type t = { x : int; y : int; }
+# Characters 5-6:
+  {x=3;z=2};;
+       ^
+Error: Unbound record field z
+# Characters 9-10:
+  fun {x=3;z=2} -> ();;
+           ^
+Error: Unbound record field z
+#     Characters 26-34:
+  {x=3; contents=2};;
+        ^^^^^^^^
+Error: The record field contents belongs to the type 'a ref
+       but is mixed here with fields of type t
+#     type u = private { mutable u : int; }
+# Characters 0-5:
+  {u=3};;
+  ^^^^^
+Error: Cannot create values of the private type u
+# Characters 11-12:
+  fun x -> x.u <- 3;;
+             ^
+Error: Cannot assign field u of the private type u
+#         module M : sig type t = { x : int; y : int; } end
+#   val f : M.t -> int = 
+# val r : M.t = {M.x = 1; y = 2}
+# val z : int = 3
+#     type foo = { mutable y : int; }
+# Characters 17-18:
+  let f (r: int) = r.y <- 3;;
+                   ^
+Error: This expression has type int but an expression was expected of type
+         foo
+#     type foo = { y : int; z : int; }
+# type bar = { x : int; }
+#     Characters 20-21:
+  let f (r: bar) = ({ r with z = 3 } : foo)
+                      ^
+Error: This expression has type bar but an expression was expected of type
+         foo
+# Characters 16-21:
+  let r : foo = { ZZZ.x = 2 };;
+                  ^^^^^
+Error: Unbound module ZZZ
+#   Characters 2-7:
+  (ZZZ.X : int option);;
+   ^^^^^
+Error: Unbound module ZZZ
+#     Characters 41-50:
+  let f (x : Complex.t) = x.Complex.z;;
+                            ^^^^^^^^^
+Error: Unbound record field Complex.z
+# 
diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference
index d69991a2..f084d039 100644
--- a/testsuite/tests/typing-misc/records.ml.reference
+++ b/testsuite/tests/typing-misc/records.ml.reference
@@ -3,16 +3,16 @@
 # Characters 5-6:
   {x=3;z=2};;
        ^
-Error: Unbound record field label z
+Error: Unbound record field z
 # Characters 9-10:
   fun {x=3;z=2} -> ();;
            ^
-Error: Unbound record field label z
+Error: Unbound record field z
 #     Characters 26-34:
   {x=3; contents=2};;
         ^^^^^^^^
-Error: The record field label Pervasives.contents belongs to the type 
-       'a ref but is mixed here with labels of type t
+Error: The record field contents belongs to the type 'a ref
+       but is mixed here with fields of type t
 #     type u = private { mutable u : int; }
 # Characters 0-5:
   {u=3};;
@@ -22,4 +22,33 @@ Error: Cannot create values of the private type u
   fun x -> x.u <- 3;;
              ^
 Error: Cannot assign field u of the private type u
+#         module M : sig type t = { x : int; y : int; } end
+#   val f : M.t -> int = 
+# val r : M.t = {M.x = 1; y = 2}
+# val z : int = 3
+#     type foo = { mutable y : int; }
+# Characters 17-18:
+  let f (r: int) = r.y <- 3;;
+                   ^
+Error: This expression has type int but an expression was expected of type
+         foo
+#     type foo = { y : int; z : int; }
+# type bar = { x : int; }
+#     Characters 20-21:
+  let f (r: bar) = ({ r with z = 3 } : foo)
+                      ^
+Error: This expression has type bar but an expression was expected of type
+         foo
+# Characters 16-21:
+  let r : foo = { ZZZ.x = 2 };;
+                  ^^^^^
+Error: Unbound module ZZZ
+#   Characters 2-7:
+  (ZZZ.X : int option);;
+   ^^^^^
+Error: Unbound module ZZZ
+#     Characters 41-50:
+  let f (x : Complex.t) = x.Complex.z;;
+                            ^^^^^^^^^
+Error: Unbound record field Complex.z
 # 
diff --git a/testsuite/tests/typing-modules-bugs/Makefile b/testsuite/tests/typing-modules-bugs/Makefile
index 9375ddba..04ded445 100644
--- a/testsuite/tests/typing-modules-bugs/Makefile
+++ b/testsuite/tests/typing-modules-bugs/Makefile
@@ -1,2 +1,14 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 include ../../makefiles/Makefile.okbad
 include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/typing-modules-bugs/pr5343_bad.ml b/testsuite/tests/typing-modules-bugs/pr5343_bad.ml
deleted file mode 100644
index 0484c677..00000000
--- a/testsuite/tests/typing-modules-bugs/pr5343_bad.ml
+++ /dev/null
@@ -1,13 +0,0 @@
-module M : sig
-  type 'a t
-  type u = u t and v = v t
-  val f : int -> u
-  val g : v -> bool
-end = struct
-  type 'a t = 'a
-  type u = int and v = bool
-  let f x = x
-  let g x = x
-end;;
-
-let h (x : int) : bool = M.g (M.f x);;
diff --git a/testsuite/tests/typing-modules-bugs/pr5914_ok.ml b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml
new file mode 100644
index 00000000..fb21cd4b
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml
@@ -0,0 +1,18 @@
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+  let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+  let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+  val bar: t
+  val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+  val foo: t -> t -> unit
+  val bar: t
+end = T
diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile
index 145025ba..02fc5fb0 100644
--- a/testsuite/tests/typing-modules/Makefile
+++ b/testsuite/tests/typing-modules/Makefile
@@ -1,2 +1,14 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 include ../../makefiles/Makefile.toplevel
 include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
index afc17054..e5cbe9f3 100644
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -38,3 +38,19 @@ let id = let module M = struct end in fun x -> x;;
 (* PR#4511 *)
 
 let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+
+(* PR#5815 *)
+
+module type S = sig exception Foo of int  exception Foo of bool end;;
diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
index c4ad0a05..8e993fa3 100644
--- a/testsuite/tests/typing-modules/Test.ml.principal.reference
+++ b/testsuite/tests/typing-modules/Test.ml.principal.reference
@@ -8,4 +8,25 @@ class type c = object method m : [ `A ] t end
 #   module M : sig val v : (#c as 'a) -> 'a end
 #       val id : 'a -> 'a = 
 #       val ko : 'a -> unit = 
+#           Characters 64-99:
+    struct type +'a t = private int end
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
+#       module type A = sig type t = X of int end
+# type u = X of bool
+# Characters 23-33:
+  module type B = A with type t = u;; (* fail *)
+                         ^^^^^^^^^^
+Error: This variant or record definition does not match that of type u
+       The types for field X are not equal.
+#       module type S = sig exception Foo of bool end
 # 
diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
index c4ad0a05..8e993fa3 100644
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ b/testsuite/tests/typing-modules/Test.ml.reference
@@ -8,4 +8,25 @@ class type c = object method m : [ `A ] t end
 #   module M : sig val v : (#c as 'a) -> 'a end
 #       val id : 'a -> 'a = 
 #       val ko : 'a -> unit = 
+#           Characters 64-99:
+    struct type +'a t = private int end
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
+#       module type A = sig type t = X of int end
+# type u = X of bool
+# Characters 23-33:
+  module type B = A with type t = u;; (* fail *)
+                         ^^^^^^^^^^
+Error: This variant or record definition does not match that of type u
+       The types for field X are not equal.
+#       module type S = sig exception Foo of bool end
 # 
diff --git a/testsuite/tests/typing-modules/pr5911.ml b/testsuite/tests/typing-modules/pr5911.ml
new file mode 100644
index 00000000..1fa991f1
--- /dev/null
+++ b/testsuite/tests/typing-modules/pr5911.ml
@@ -0,0 +1,14 @@
+module type S = sig
+ type t
+ val x : t
+end;;
+
+module Good (X : S with type t := unit) = struct
+ let () = X.x
+end;;
+
+module type T = sig module M : S end;;
+
+module Bad (X : T with type M.t := unit) = struct
+ let () = X.M.x
+end;;
diff --git a/testsuite/tests/typing-modules/pr5911.ml.reference b/testsuite/tests/typing-modules/pr5911.ml.reference
new file mode 100644
index 00000000..e5357b84
--- /dev/null
+++ b/testsuite/tests/typing-modules/pr5911.ml.reference
@@ -0,0 +1,9 @@
+
+#       module type S = sig type t val x : t end
+#       module Good : functor (X : sig val x : unit end) -> sig  end
+#   module type T = sig module M : S end
+#       Characters 33-35:
+  module Bad (X : T with type M.t := unit) = struct
+                                  ^^
+Error: Syntax error
+# 
diff --git a/testsuite/tests/typing-objects-bugs/Makefile b/testsuite/tests/typing-objects-bugs/Makefile
index 1b07f206..1103dbff 100644
--- a/testsuite/tests/typing-objects-bugs/Makefile
+++ b/testsuite/tests/typing-objects-bugs/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.okbad
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
index d6f9d6df..0b04607a 100644
--- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
@@ -93,7 +93,7 @@ Error: Type
        is not a subtype of
          point circle =
            < center : point; move : int -> unit; set_center : point -> unit > 
-Type point = point is not a subtype of color_point = color_point 
+       Type point is not a subtype of color_point 
 # Characters 9-55:
   fun x -> (x : color_point color_circle :> point circle);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -104,7 +104,7 @@ Error: Type
        is not a subtype of
          point circle =
            < center : point; move : int -> unit; set_center : point -> unit > 
-Type point = point is not a subtype of color_point = color_point 
+       Type point is not a subtype of color_point 
 #         class printable_point :
   int ->
   object
@@ -215,10 +215,10 @@ Error: Type
            < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
        is not a subtype of
          int_comparable = < leq : int_comparable -> bool; x : int > 
-Type int_comparable = < leq : int_comparable -> bool; x : int >
-is not a subtype of
-  int_comparable2 =
-    < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > 
+       Type int_comparable = < leq : int_comparable -> bool; x : int >
+       is not a subtype of
+         int_comparable2 =
+           < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > 
 # - : unit = ()
 #             class int_comparable3 :
   int ->
diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference
index 128d1be7..353f607c 100644
--- a/testsuite/tests/typing-objects/Exemples.ml.reference
+++ b/testsuite/tests/typing-objects/Exemples.ml.reference
@@ -93,7 +93,7 @@ Error: Type
        is not a subtype of
          point circle =
            < center : point; move : int -> unit; set_center : point -> unit > 
-Type point = point is not a subtype of color_point = color_point 
+       Type point is not a subtype of color_point 
 # Characters 9-55:
   fun x -> (x : color_point color_circle :> point circle);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -104,7 +104,7 @@ Error: Type
        is not a subtype of
          point circle =
            < center : point; move : int -> unit; set_center : point -> unit > 
-Type point = point is not a subtype of color_point = color_point 
+       Type point is not a subtype of color_point 
 #         class printable_point :
   int ->
   object
@@ -215,10 +215,10 @@ Error: Type
            < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
        is not a subtype of
          int_comparable = < leq : int_comparable -> bool; x : int > 
-Type int_comparable = < leq : int_comparable -> bool; x : int >
-is not a subtype of
-  int_comparable2 =
-    < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > 
+       Type int_comparable = < leq : int_comparable -> bool; x : int >
+       is not a subtype of
+         int_comparable2 =
+           < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > 
 # - : unit = ()
 #             class int_comparable3 :
   int ->
diff --git a/testsuite/tests/typing-objects/Makefile b/testsuite/tests/typing-objects/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-objects/Makefile
+++ b/testsuite/tests/typing-objects/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index 15bef7f9..befd70d9 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -325,3 +325,10 @@ let o = object val x = 33 val y = 44 method m = x end in
   let o' :  = Marshal.from_string s 0 in
   let o'' :  = Marshal.from_string s 0 in
   (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;
+
+(* Recursion (cf. PR#5291) *)
+
+class a = let _ = new b in object end
+and b = let _ = new a in object end;;
+
+class a = let _ = new a in object end;;
diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index a194f7d0..52f2a092 100644
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -254,10 +254,12 @@ Error: Multiple definition of the type name t.
   fun x -> (x : int -> bool :> 'a -> 'a);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
 # Characters 9-40:
   fun x -> (x : int -> bool :> int -> int);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
 # - : <  > -> <  > = 
 # - : < .. > -> <  > = 
 #   val x : '_a list ref = {contents = []}
@@ -293,10 +295,18 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
-#       - : int = 15
-# - : int = 16
+#       - : int = 16
 # - : int = 17
-#         - : int * int * int = (18, 19, 20)
-#           - : int * int * int * int * int = (21, 22, 23, 33, 33)
-#           - : int * int * int * int * int = (24, 25, 26, 33, 33)
+# - : int = 18
+#         - : int * int * int = (19, 20, 21)
+#           - : int * int * int * int * int = (22, 23, 24, 33, 33)
+#           - : int * int * int * int * int = (25, 26, 27, 33, 33)
+#         Characters 42-69:
+  class a = let _ = new b in object end
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+#   Characters 11-38:
+  class a = let _ = new a in object end;;
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
 # 
diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index d5d0bea4..038f3dd5 100644
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -254,10 +254,12 @@ Error: Multiple definition of the type name t.
   fun x -> (x : int -> bool :> 'a -> 'a);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
 # Characters 9-40:
   fun x -> (x : int -> bool :> int -> int);;
            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type int -> bool is not a subtype of int -> int 
+       Type bool is not a subtype of int 
 # - : <  > -> <  > = 
 # - : < .. > -> <  > = 
 #   val x : '_a list ref = {contents = []}
@@ -292,10 +294,18 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
-#       - : int = 15
-# - : int = 16
+#       - : int = 16
 # - : int = 17
-#         - : int * int * int = (18, 19, 20)
-#           - : int * int * int * int * int = (21, 22, 23, 33, 33)
-#           - : int * int * int * int * int = (24, 25, 26, 33, 33)
+# - : int = 18
+#         - : int * int * int = (19, 20, 21)
+#           - : int * int * int * int * int = (22, 23, 24, 33, 33)
+#           - : int * int * int * int * int = (25, 26, 27, 33, 33)
+#         Characters 42-69:
+  class a = let _ = new b in object end
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+#   Characters 11-38:
+  class a = let _ = new a in object end;;
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
 # 
diff --git a/testsuite/tests/typing-objects/pr5858.ml b/testsuite/tests/typing-objects/pr5858.ml
new file mode 100644
index 00000000..3795cf31
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5858.ml
@@ -0,0 +1,2 @@
+class type c = object end;;
+module type S = sig class c: c end;;
diff --git a/testsuite/tests/typing-objects/pr5858.ml.reference b/testsuite/tests/typing-objects/pr5858.ml.reference
new file mode 100644
index 00000000..94e63484
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr5858.ml.reference
@@ -0,0 +1,7 @@
+
+# class type c = object  end
+# Characters 29-30:
+  module type S = sig class c: c end;;
+                               ^
+Error: The class type c is not yet completely defined
+# 
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml b/testsuite/tests/typing-objects/pr6123_bad.ml
new file mode 100644
index 00000000..a773f8d7
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml
@@ -0,0 +1,23 @@
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+  inherit name
+
+  val mutable memo_args = None
+
+  method arguments =
+    match memo_args with
+    | Some xs -> xs
+    | None ->
+      let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+        memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+  inherit name
+end
+;;
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference
new file mode 100644
index 00000000..a7e48182
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference
@@ -0,0 +1,8 @@
+
+#                                             Characters 253-257:
+        let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+                                                    ^^^^
+Error: This expression has type < arguments : 'b; .. > as 'a
+       but an expression was expected of type 'a
+       Self type cannot escape its class
+# 
diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.reference
new file mode 100644
index 00000000..a7e48182
--- /dev/null
+++ b/testsuite/tests/typing-objects/pr6123_bad.ml.reference
@@ -0,0 +1,8 @@
+
+#                                             Characters 253-257:
+        let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+                                                    ^^^^
+Error: This expression has type < arguments : 'b; .. > as 'a
+       but an expression was expected of type 'a
+       Self type cannot escape its class
+# 
diff --git a/testsuite/tests/typing-poly-bugs/Makefile b/testsuite/tests/typing-poly-bugs/Makefile
index 1b07f206..1103dbff 100644
--- a/testsuite/tests/typing-poly-bugs/Makefile
+++ b/testsuite/tests/typing-poly-bugs/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.okbad
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly-bugs/pr5673_bad.ml b/testsuite/tests/typing-poly-bugs/pr5673_bad.ml
new file mode 100644
index 00000000..454ab1b4
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5673_bad.ml
@@ -0,0 +1,23 @@
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object 
+      constraint 'c = < m : 'a -> 'b -> int; .. > 
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
diff --git a/testsuite/tests/typing-poly-bugs/pr5673_ok.ml b/testsuite/tests/typing-poly-bugs/pr5673_ok.ml
new file mode 100644
index 00000000..df9fd215
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5673_ok.ml
@@ -0,0 +1,23 @@
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object 
+      constraint 'c = < m : 'a -> 'b -> int; .. > 
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+module M : sig
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-poly/Makefile
+++ b/testsuite/tests/typing-poly/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
index 85196f16..36dc76a4 100644
--- a/testsuite/tests/typing-poly/poly.ml
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -1,4 +1,3 @@
-(* $Id: poly.ml 12800 2012-07-30 18:59:07Z doligez $ *)
 (*
    Polymorphic methods are now available in the main branch.
    Enjoy.
@@ -170,7 +169,7 @@ let p0 = new point ~x:3 ~y:5
 let p1 = new point ~x:10 ~y:13
 let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
 let c = new circle p0 ~r:2
-let d = c#distance cp
+let d = floor (c#distance cp)
 ;;
 let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
 ;;
@@ -655,3 +654,16 @@ let (A x) = (raise Exit : s);;
 (* PR#5224 *)
 
 type 'x t = < f : 'y. 'y t >;;
+
+(* PR#6056, PR#6057 *)
+let using_match b =
+  let f =
+    match b with
+    | true -> fun x -> x
+    | false -> fun x -> x
+  in
+  f 0,f
+;;
+
+match (fun x -> x), fun x -> x with x, y -> x, y;;
+match fun x -> x with x -> x, x;;
diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference
index d069595e..53acb415 100644
--- a/testsuite/tests/typing-poly/poly.ml.principal.reference
+++ b/testsuite/tests/typing-poly/poly.ml.principal.reference
@@ -1,5 +1,5 @@
 
-#   * * *       #   type 'a t = { t : 'a; }
+# * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = 
 # - : int = 6
@@ -118,7 +118,7 @@
 val p1 : point = 
 val cp : color_point = 
 val c : circle = 
-val d : float = 11.4536240470737098
+val d : float = 11.
 #   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
 #   Characters 41-42:
   let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
@@ -454,6 +454,7 @@ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
          :>  ('a * 'foo)> as 'foo)..
 Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
        is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
+       Type 'c. 'e is not a subtype of 'a. 'g 
 #       Characters 88-150:
   = struct let f (x :  as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -512,6 +513,8 @@ Error: Type p = < x : p > is not a subtype of q = < x : p; .. >
       :>  as 'b) -> int>)..
 Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
+       Type < p : int; q : int; .. > as 'c is not a subtype of
+         < p : int; .. > as 'd 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
   < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
@@ -520,12 +523,13 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
       :> ;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
        is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
+       Type < a : int > is not a subtype of < a : int; b : int > 
 # Characters 11-55:
   let f4 x = (x : ;..> :> ;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < p : < a : int; b : int >; .. > is not a subtype of
          < p : < a : int >; .. > 
-The second object type has no method b
+       The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
   < m : 'b. [< `A of <  > ] as 'b > = 
@@ -534,6 +538,7 @@ The second object type has no method b
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
          < m : 'b. [< `A of < p : int > ] as 'b > 
+       Type <  > is not a subtype of < p : int > 
 #     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
 # Characters 9-16:
   fun x -> (f x)#m;; (* Warning 18 *)
@@ -592,7 +597,7 @@ Error: This definition has type 'a t -> 'a which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'b 'a. 'a t -> 'b
+         'a 'b. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = 
 # val f : 'a -> 'a = 
@@ -639,4 +644,7 @@ Error: This field value has type unit -> unit which is less general than
   type 'x t = < f : 'y. 'y t >;;
       ^^^^^^^^^^^^^^^^^^^^^^^^
 Error: In the definition of t, type 'y t should be 'x t
+#                   val using_match : bool -> int * ('a -> 'a) = 
+#   - : ('a -> 'a) * ('b -> 'b) = (, )
+# - : ('a -> 'a) * ('b -> 'b) = (, )
 # 
diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference
index 81fb3473..9929020d 100644
--- a/testsuite/tests/typing-poly/poly.ml.reference
+++ b/testsuite/tests/typing-poly/poly.ml.reference
@@ -1,5 +1,5 @@
 
-#   * * *       #   type 'a t = { t : 'a; }
+# * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = 
 # - : int = 6
@@ -118,7 +118,7 @@
 val p1 : point = 
 val cp : color_point = 
 val c : circle = 
-val d : float = 11.4536240470737098
+val d : float = 11.
 #   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = 
 #   Characters 41-42:
   let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
@@ -437,6 +437,7 @@ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
          :>  ('a * 'foo)> as 'foo)..
 Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
        is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
+       Type 'c. 'e is not a subtype of 'a. 'g 
 #       Characters 88-150:
   = struct let f (x :  as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -490,6 +491,8 @@ Error: Type p = < x : p > is not a subtype of q = < x : p; .. >
       :>  as 'b) -> int>)..
 Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
+       Type < p : int; q : int; .. > as 'c is not a subtype of
+         < p : int; .. > as 'd 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
   < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = 
@@ -498,12 +501,13 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
       :> ;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
        is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
+       Type < a : int > is not a subtype of < a : int; b : int > 
 # Characters 11-55:
   let f4 x = (x : ;..> :> ;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < p : < a : int; b : int >; .. > is not a subtype of
          < p : < a : int >; .. > 
-The second object type has no method b
+       The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
   < m : 'b. [< `A of <  > ] as 'b > = 
@@ -512,6 +516,7 @@ The second object type has no method b
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
          < m : 'b. [< `A of < p : int > ] as 'b > 
+       Type <  > is not a subtype of < p : int > 
 #     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = 
 # - : < m : 'a. 'a -> 'a > -> 'b -> 'b = 
 # val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = 
@@ -550,7 +555,7 @@ Error: This definition has type 'a t -> 'a which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'b 'a. 'a t -> 'b
+         'a 'b. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = 
 # val f : 'a -> 'a = 
@@ -597,4 +602,7 @@ Error: This field value has type unit -> unit which is less general than
   type 'x t = < f : 'y. 'y t >;;
       ^^^^^^^^^^^^^^^^^^^^^^^^
 Error: In the definition of t, type 'y t should be 'x t
+#                   val using_match : bool -> int * ('a -> 'a) = 
+#   - : ('a -> 'a) * ('b -> 'b) = (, )
+# - : ('a -> 'a) * ('b -> 'b) = (, )
 # 
diff --git a/testsuite/tests/typing-polyvariants-bugs-2/Makefile b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
index 9ecfbe38..4cf35f3c 100644
--- a/testsuite/tests/typing-polyvariants-bugs-2/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
@@ -1,7 +1,22 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 default:
 	@printf " ... testing 'pr3918':"
-	@($(OCAMLC) -c pr3918a.mli && $(OCAMLC) -c pr3918b.mli && $(OCAMLC) -c pr3918c.ml && echo " => passed") || echo " => failed"
+	@($(OCAMLC) -c pr3918a.mli \
+	&& $(OCAMLC) -c pr3918b.mli \
+	&& $(OCAMLC) -c pr3918c.ml \
+	&& echo " => passed") || echo " => failed"
 
 clean: defaultclean
 
diff --git a/testsuite/tests/typing-polyvariants-bugs/Makefile b/testsuite/tests/typing-polyvariants-bugs/Makefile
index 1b07f206..1103dbff 100644
--- a/testsuite/tests/typing-polyvariants-bugs/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.okbad
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private-bugs/Makefile b/testsuite/tests/typing-private-bugs/Makefile
index 1b07f206..1103dbff 100644
--- a/testsuite/tests/typing-private-bugs/Makefile
+++ b/testsuite/tests/typing-private-bugs/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.okbad
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private/Makefile b/testsuite/tests/typing-private/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-private/Makefile
+++ b/testsuite/tests/typing-private/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-private/private.ml b/testsuite/tests/typing-private/private.ml
index 6f19b89d..2ad00183 100644
--- a/testsuite/tests/typing-private/private.ml
+++ b/testsuite/tests/typing-private/private.ml
@@ -87,3 +87,19 @@ module M3' : sig
   type t = M'.t
   val mk : int -> t
 end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+  struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+  struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+   but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference
index 8a7b3db4..c9f0b5a0 100644
--- a/testsuite/tests/typing-private/private.ml.reference
+++ b/testsuite/tests/typing-private/private.ml.reference
@@ -94,4 +94,15 @@ Error: This variant or record definition does not match that of type M.t
 #                   module M' :
   sig type t_priv = private T of int type t = t_priv val mk : int -> t end
 #         module M3' : sig type t = M'.t val mk : int -> t end
+#     module M : sig type 'a t = private T of 'a end
+#     module M1 : sig type 'a t = 'a M.t = private T of 'a end
+#       module Test : sig type t = private A end
+module Test2 : sig type t = Test.t = private A end
+# val f : Test.t -> Test2.t = 
+# val f : Test2.t -> unit = 
+# Characters 8-15:
+  let a = Test2.A;; (* fail *)
+          ^^^^^^^
+Error: Cannot create values of the private type Test2.t
+# *   module Test2 : sig type t = Test.t = private A end
 # 
diff --git a/testsuite/tests/typing-recmod/Makefile b/testsuite/tests/typing-recmod/Makefile
index 1b07f206..1103dbff 100644
--- a/testsuite/tests/typing-recmod/Makefile
+++ b/testsuite/tests/typing-recmod/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.okbad
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-rectypes-bugs/Makefile b/testsuite/tests/typing-rectypes-bugs/Makefile
new file mode 100644
index 00000000..e0202b0a
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/Makefile
@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
+COMPFLAGS = -rectypes
diff --git a/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml b/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml
new file mode 100644
index 00000000..0484c677
--- /dev/null
+++ b/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml
@@ -0,0 +1,13 @@
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
diff --git a/testsuite/tests/typing-short-paths/Makefile b/testsuite/tests/typing-short-paths/Makefile
new file mode 100644
index 00000000..3b7cbaa3
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/Makefile
@@ -0,0 +1,16 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -short-paths
diff --git a/testsuite/tests/typing-short-paths/pr5918.ml b/testsuite/tests/typing-short-paths/pr5918.ml
new file mode 100644
index 00000000..604f66d8
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr5918.ml
@@ -0,0 +1,7 @@
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
diff --git a/testsuite/tests/typing-short-paths/pr5918.ml.reference b/testsuite/tests/typing-short-paths/pr5918.ml.reference
new file mode 100644
index 00000000..3364e16d
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr5918.ml.reference
@@ -0,0 +1,6 @@
+
+#             Characters 82-92:
+   let _ = { a = () }
+           ^^^^^^^^^^
+Error: Some record fields are undefined: b
+# 
diff --git a/testsuite/tests/typing-short-paths/short-paths.ml b/testsuite/tests/typing-short-paths/short-paths.ml
new file mode 100644
index 00000000..56160906
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/short-paths.ml
@@ -0,0 +1,48 @@
+module Core = struct
+  module Int = struct
+    module T = struct
+      type t = int
+      let compare = compare
+      let (+) x y = x + y
+    end
+    include T
+    module Map = Map.Make(T)
+  end
+
+  module Std = struct
+    module Int = Int
+  end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference
new file mode 100644
index 00000000..4c1a991a
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference
@@ -0,0 +1,117 @@
+
+#                               module Core :
+  sig
+    module Int :
+      sig
+        module T :
+          sig
+            type t = int
+            val compare : 'a -> 'a -> t
+            val ( + ) : t -> t -> t
+          end
+        type t = int
+        val compare : 'a -> 'a -> t
+        val ( + ) : t -> t -> t
+        module Map :
+          sig
+            type key = t
+            type 'a t = 'a Map.Make(T).t
+            val empty : 'a t
+            val is_empty : 'a t -> bool
+            val mem : key -> 'a t -> bool
+            val add : key -> 'a -> 'a t -> 'a t
+            val singleton : key -> 'a -> 'a t
+            val remove : key -> 'a t -> 'a t
+            val merge :
+              (key -> 'a option -> 'b option -> 'c option) ->
+              'a t -> 'b t -> 'c t
+            val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+            val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+            val iter : (key -> 'a -> unit) -> 'a t -> unit
+            val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+            val for_all : (key -> 'a -> bool) -> 'a t -> bool
+            val exists : (key -> 'a -> bool) -> 'a t -> bool
+            val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+            val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+            val cardinal : 'a t -> key
+            val bindings : 'a t -> (key * 'a) list
+            val min_binding : 'a t -> key * 'a
+            val max_binding : 'a t -> key * 'a
+            val choose : 'a t -> key * 'a
+            val split : key -> 'a t -> 'a t * 'a option * 'a t
+            val find : key -> 'a t -> 'a
+            val map : ('a -> 'b) -> 'a t -> 'b t
+            val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+          end
+      end
+    module Std :
+      sig
+        module Int :
+          sig
+            module T :
+              sig
+                type t = int
+                val compare : 'a -> 'a -> t
+                val ( + ) : t -> t -> t
+              end
+            type t = int
+            val compare : 'a -> 'a -> t
+            val ( + ) : t -> t -> t
+            module Map :
+              sig
+                type key = t
+                type 'a t = 'a Map.Make(T).t
+                val empty : 'a t
+                val is_empty : 'a t -> bool
+                val mem : key -> 'a t -> bool
+                val add : key -> 'a -> 'a t -> 'a t
+                val singleton : key -> 'a -> 'a t
+                val remove : key -> 'a t -> 'a t
+                val merge :
+                  (key -> 'a option -> 'b option -> 'c option) ->
+                  'a t -> 'b t -> 'c t
+                val compare : ('a -> 'a -> key) -> 'a t -> 'a t -> key
+                val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+                val iter : (key -> 'a -> unit) -> 'a t -> unit
+                val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+                val for_all : (key -> 'a -> bool) -> 'a t -> bool
+                val exists : (key -> 'a -> bool) -> 'a t -> bool
+                val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+                val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+                val cardinal : 'a t -> key
+                val bindings : 'a t -> (key * 'a) list
+                val min_binding : 'a t -> key * 'a
+                val max_binding : 'a t -> key * 'a
+                val choose : 'a t -> key * 'a
+                val split : key -> 'a t -> 'a t * 'a option * 'a t
+                val find : key -> 'a t -> 'a
+                val map : ('a -> 'b) -> 'a t -> 'b t
+                val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+              end
+          end
+      end
+  end
+#     #   val x : 'a Int.Map.t = 
+# Characters 8-9:
+  let y = x + x ;;
+          ^
+Error: This expression has type 'a Int.Map.t
+       but an expression was expected of type int
+#           module M : sig type t = A type u = C end
+module N : sig type t = B end
+# - : M.t = A
+# - : N.t = B
+# - : u = C
+#   type t = M.t = A
+type u = M.u = C
+# - : u = C
+#     module L : sig type v = V end
+# - : v = V
+#   module L : sig type v = V end
+# - : v = V
+#     type t1 = A
+# module M1 : sig type u = v and v = t1 end
+# module N1 : sig type u = v and v = t1 end
+# type t1 = B
+# module N2 : sig type u = v and v = N1.v end
+# 
diff --git a/testsuite/tests/typing-signatures/Makefile b/testsuite/tests/typing-signatures/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-signatures/Makefile
+++ b/testsuite/tests/typing-signatures/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-sigsubst/Makefile
+++ b/testsuite/tests/typing-sigsubst/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-typeparam/Makefile b/testsuite/tests/typing-typeparam/Makefile
index 9625a3fb..c9433b2e 100644
--- a/testsuite/tests/typing-typeparam/Makefile
+++ b/testsuite/tests/typing-typeparam/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/typing-warnings/Makefile b/testsuite/tests/typing-warnings/Makefile
new file mode 100644
index 00000000..9d79c58e
--- /dev/null
+++ b/testsuite/tests/typing-warnings/Makefile
@@ -0,0 +1,16 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -w A
diff --git a/testsuite/tests/typing-warnings/pr5892.ml b/testsuite/tests/typing-warnings/pr5892.ml
new file mode 100644
index 00000000..bbc73b55
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr5892.ml
@@ -0,0 +1,3 @@
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
diff --git a/testsuite/tests/typing-warnings/pr5892.ml.reference b/testsuite/tests/typing-warnings/pr5892.ml.reference
new file mode 100644
index 00000000..1321634a
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr5892.ml.reference
@@ -0,0 +1,12 @@
+
+# # type _ choice =
+    Left : CamlinternalOO.label choice
+  | Right : CamlinternalOO.tag choice
+# Characters 31-52:
+  let f : label choice -> bool = function Left -> true;; (* warn *)
+                                 ^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Right
+val f : CamlinternalOO.label choice -> bool = 
+# 
diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml
new file mode 100644
index 00000000..61a21ceb
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml
@@ -0,0 +1,160 @@
+(* Use type information *)
+module M1 = struct
+  type t = {x: int; y: int}
+  type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+  open M1
+  let f1 (r:t) = r.x (* ok *)
+  let f2 r = ignore (r:t); r.x (* non principal *)
+
+  let f3 (r: t) =
+    match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+  open M1
+  let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+  open M1
+  let f r =
+    ignore (r: t);
+    match r with
+       {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+  type t = {x:int}
+  type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+  type t = {x: int; y: int}
+end;;
+module N = struct
+  type u = {x: bool; y: bool}
+end;;
+module OK = struct
+  open M
+  open N
+  let f (r:M.t) = r.x
+end;; 
+
+module M = struct
+  type t = {x:int}
+  module N = struct type s = t = {x:int} end
+  type u = {x:bool}
+end;;
+module OK = struct
+  open M.N
+  let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+  type u = {x:bool;y:int;z:char}
+  type t = {x:int;y:bool}
+end;;
+module OK = struct
+  open M
+  let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+  open M
+  let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+  type u = {x:int;y:bool}
+  type t = {x:bool;y:int;z:char}
+  let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+  type foo = {x:int; y:int}
+  type bar = {x:int}
+  let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+  type foo = { x: int; y: int }
+  type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+  open M
+  let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+  include M
+  type other = { a: int; b: int }
+end;;
+module F6 = struct
+  open M
+  let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+  open M
+  let r = {x=1; y=2}
+  let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+  type t = {x:int; yyy:int}
+  let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+  let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open shadows label 'x' *)
+  let y = {x = ""}
+end;;
diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference
new file mode 100644
index 00000000..7c66a0ab
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -0,0 +1,279 @@
+
+#         module M1 :
+  sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+#                 Characters 49-50:
+    let f1 (r:t) = r.x (* ok *)
+                     ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 18: this type-based field disambiguation is not principal.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 42: this use of x required disambiguation.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 42: this use of x required disambiguation.
+Characters 151-152:
+      match r with {x; y} -> y + y (* ok *)
+                       ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                       ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 27: unused variable x.
+module OK :
+  sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+#         Characters 55-61:
+    let f r = match r with {x; y} -> y + y
+                           ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+    let f r = match r with {x; y} -> y + y
+                                     ^
+Error: This expression has type bool but an expression was expected of type
+         int
+#               Characters 85-91:
+         {x; y} -> y + y
+         ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 85-91:
+         {x; y} -> y + y
+         ^^^^^^
+Error: This pattern matches values of type M1.u
+       but a pattern was expected which matches values of type M1.t
+#           module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+  let f (r:M.t) = r.M.x;; (* ok *)
+                    ^^^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = 
+# Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not 
+be selected if the type becomes unknown.
+Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = 
+# Characters 8-9:
+  let f ({x}:M.t) = x;; (* warning *)
+          ^
+Warning 42: this use of x required disambiguation.
+Characters 7-10:
+  let f ({x}:M.t) = x;; (* warning *)
+         ^^^
+Warning 40: this record of type M.t contains fields that are 
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = 
+#       module M : sig type t = { x : int; y : int; } end
+#     module N : sig type u = { x : bool; y : bool; } end
+#         Characters 57-58:
+    let f (r:M.t) = r.x
+                      ^
+Warning 42: this use of x required disambiguation.
+Characters 30-36:
+    open N
+    ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+  ...... M
+    open N
+    let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type t = { x : int; }
+    module N : sig type s = t = { x : int; } end
+    type u = { x : bool; }
+  end
+#       module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type u = { x : bool; y : int; z : char; }
+    type t = { x : int; y : bool; }
+  end
+#       Characters 37-38:
+    let f {x;z} = x,z
+           ^
+Warning 42: this use of x required disambiguation.
+Characters 36-41:
+    let f {x;z} = x,z
+          ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+  Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+#       Characters 38-52:
+    let r = {x=true;z='z'}
+            ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+#           Characters 90-91:
+    let r = {x=3; y=true}
+             ^
+Warning 42: this use of x required disambiguation.
+Characters 95-96:
+    let r = {x=3; y=true}
+                  ^
+Warning 42: this use of y required disambiguation.
+module OK :
+  sig
+    type u = { x : int; y : bool; }
+    type t = { x : bool; y : int; z : char; }
+    val r : u
+  end
+#               Characters 111-112:
+    let b : bar = {x=3; y=4}
+                        ^
+Error: The record type bar has no field y
+#   module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+  let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+                     ^^^
+Error: The record field N.y belongs to the type N.bar
+       but is mixed here with fields of type M.foo
+#     module MN :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = N.bar = { x : int; y : int; }
+  end
+module NM :
+  sig
+    type bar = N.bar = { x : int; y : int; }
+    type foo = M.foo = { x : int; y : int; }
+  end
+# Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+                     ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+       but is mixed here with fields of type MN.bar = N.bar
+#             module M :
+  sig
+    type foo = { x : int; y : int; }
+    type bar = { x : int; y : int; z : int; }
+  end
+#       Characters 65-66:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                       ^
+Warning 42: this use of x required disambiguation.
+Characters 72-73:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                              ^
+Error: The record type M.foo has no field z
+#       module M :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = M.bar = { x : int; y : int; z : int; }
+    type other = { a : int; b : int; }
+  end
+#       Characters 66-67:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                        ^
+Warning 42: this use of x required disambiguation.
+Characters 73-74:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                               ^
+Error: The record type M.foo has no field a
+#         Characters 39-40:
+    let r = {x=1; y=2}
+             ^
+Warning 42: this use of x required disambiguation.
+Characters 44-45:
+    let r = {x=1; y=2}
+                  ^
+Warning 42: this use of y required disambiguation.
+Characters 67-68:
+    let r: other = {x=1; y=2}
+                    ^
+Error: The record type M.other has no field x
+#     module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+  let f (r : B.t) = r.A.x;; (* fail *)
+                      ^^^
+Error: The field A.x belongs to the record type A.t
+       but a field was expected belonging to the record type B.t
+#             Characters 88-91:
+    let a : t = {x=1;yyz=2}
+                     ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+#             type t = A
+type s = A
+class f : t -> object  end
+# Characters 12-13:
+  class g = f A;; (* ok *)
+              ^
+Warning 42: this use of A required disambiguation.
+class g : f
+#   class f : 'a -> 'a -> object  end
+# Characters 13-14:
+  class g = f (A : t) A;; (* warn with -principal *)
+               ^
+Warning 42: this use of A required disambiguation.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 18: this type-based constructor disambiguation is not principal.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 42: this use of A required disambiguation.
+class g : f
+#                       Characters 199-200:
+    let y : t = {x = 0}
+                 ^
+Warning 42: this use of x required disambiguation.
+Characters 114-120:
+    open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+    ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : t
+  end
+#               Characters 97-103:
+    open M  (* this open shadows label 'x' *)
+    ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+    let y = {x = ""}
+            ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : M.s
+  end
+# 
diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference
new file mode 100644
index 00000000..2952abd6
--- /dev/null
+++ b/testsuite/tests/typing-warnings/records.ml.reference
@@ -0,0 +1,278 @@
+
+#         module M1 :
+  sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+#                 Characters 49-50:
+    let f1 (r:t) = r.x (* ok *)
+                     ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                               ^
+Warning 42: this use of x required disambiguation.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 42: this use of x required disambiguation.
+Characters 151-152:
+      match r with {x; y} -> y + y (* ok *)
+                       ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+    let f2 r = ignore (r:t); r.x (* non principal *)
+                       ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+      match r with {x; y} -> y + y (* ok *)
+                    ^
+Warning 27: unused variable x.
+module OK :
+  sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+#         Characters 55-61:
+    let f r = match r with {x; y} -> y + y
+                           ^^^^^^
+Warning 41: these field labels belong to several types: M1.u M1.t
+The first one was selected. Please disambiguate if this is wrong.
+Characters 65-66:
+    let f r = match r with {x; y} -> y + y
+                                     ^
+Error: This expression has type bool but an expression was expected of type
+         int
+#               Characters 86-87:
+         {x; y} -> y + y
+          ^
+Warning 42: this use of x required disambiguation.
+Characters 89-90:
+         {x; y} -> y + y
+             ^
+Warning 42: this use of y required disambiguation.
+Characters 81-103:
+  ...    {x; y} -> y + y
+  en..............................
+Warning 34: unused type u.
+Characters 86-87:
+         {x; y} -> y + y
+          ^
+Warning 27: unused variable x.
+module F2 : sig val f : M1.t -> int end
+#           module M : sig type t = { x : int; } type u = { x : bool; } end
+# Characters 18-21:
+  let f (r:M.t) = r.M.x;; (* ok *)
+                    ^^^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = 
+# Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 40: x was selected from type M.t.
+It is not visible in the current scope, and will not 
+be selected if the type becomes unknown.
+Characters 18-19:
+  let f (r:M.t) = r.x;; (* warning *)
+                    ^
+Warning 42: this use of x required disambiguation.
+val f : M.t -> int = 
+# Characters 8-9:
+  let f ({x}:M.t) = x;; (* warning *)
+          ^
+Warning 42: this use of x required disambiguation.
+Characters 7-10:
+  let f ({x}:M.t) = x;; (* warning *)
+         ^^^
+Warning 40: this record of type M.t contains fields that are 
+not visible in the current scope: x.
+They will not be selected if the type becomes unknown.
+val f : M.t -> int = 
+#       module M : sig type t = { x : int; y : int; } end
+#     module N : sig type u = { x : bool; y : bool; } end
+#         Characters 57-58:
+    let f (r:M.t) = r.x
+                      ^
+Warning 42: this use of x required disambiguation.
+Characters 30-36:
+    open N
+    ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+  ...... M
+    open N
+    let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type t = { x : int; }
+    module N : sig type s = t = { x : int; } end
+    type u = { x : bool; }
+  end
+#       module OK : sig val f : M.t -> int end
+#           module M :
+  sig
+    type u = { x : bool; y : int; z : char; }
+    type t = { x : int; y : bool; }
+  end
+#       Characters 37-38:
+    let f {x;z} = x,z
+           ^
+Warning 42: this use of x required disambiguation.
+Characters 36-41:
+    let f {x;z} = x,z
+          ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+  Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+#       Characters 38-52:
+    let r = {x=true;z='z'}
+            ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+#           Characters 90-91:
+    let r = {x=3; y=true}
+             ^
+Warning 42: this use of x required disambiguation.
+Characters 95-96:
+    let r = {x=3; y=true}
+                  ^
+Warning 42: this use of y required disambiguation.
+module OK :
+  sig
+    type u = { x : int; y : bool; }
+    type t = { x : bool; y : int; z : char; }
+    val r : u
+  end
+#               Characters 111-112:
+    let b : bar = {x=3; y=4}
+                        ^
+Error: The record type bar has no field y
+#   module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+  let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+                     ^^^
+Error: The record field N.y belongs to the type N.bar
+       but is mixed here with fields of type M.foo
+#     module MN :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = N.bar = { x : int; y : int; }
+  end
+module NM :
+  sig
+    type bar = N.bar = { x : int; y : int; }
+    type foo = M.foo = { x : int; y : int; }
+  end
+# Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: x belongs to several types: MN.bar MN.foo
+The first one was selected. Please disambiguate if this is wrong.
+Characters 8-28:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+          ^^^^^^^^^^^^^^^^^^^^
+Warning 41: y belongs to several types: NM.foo NM.bar
+The first one was selected. Please disambiguate if this is wrong.
+Characters 19-23:
+  let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+                     ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+       but is mixed here with fields of type MN.bar = N.bar
+#             module M :
+  sig
+    type foo = { x : int; y : int; }
+    type bar = { x : int; y : int; z : int; }
+  end
+#       Characters 65-66:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                       ^
+Warning 42: this use of x required disambiguation.
+Characters 72-73:
+    let f r = ignore (r: foo); {r with x = 2; z = 3}
+                                              ^
+Error: The record type M.foo has no field z
+#       module M :
+  sig
+    type foo = M.foo = { x : int; y : int; }
+    type bar = M.bar = { x : int; y : int; z : int; }
+    type other = { a : int; b : int; }
+  end
+#       Characters 66-67:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                        ^
+Warning 42: this use of x required disambiguation.
+Characters 73-74:
+    let f r = ignore (r: foo); { r with x = 3; a = 4 }
+                                               ^
+Error: The record type M.foo has no field a
+#         Characters 39-40:
+    let r = {x=1; y=2}
+             ^
+Warning 42: this use of x required disambiguation.
+Characters 44-45:
+    let r = {x=1; y=2}
+                  ^
+Warning 42: this use of y required disambiguation.
+Characters 67-68:
+    let r: other = {x=1; y=2}
+                    ^
+Error: The record type M.other has no field x
+#     module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+  let f (r : B.t) = r.A.x;; (* fail *)
+                      ^^^
+Error: The field A.x belongs to the record type A.t
+       but a field was expected belonging to the record type B.t
+#             Characters 88-91:
+    let a : t = {x=1;yyz=2}
+                     ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+#             type t = A
+type s = A
+class f : t -> object  end
+# Characters 12-13:
+  class g = f A;; (* ok *)
+              ^
+Warning 42: this use of A required disambiguation.
+class g : f
+#   class f : 'a -> 'a -> object  end
+# Characters 13-14:
+  class g = f (A : t) A;; (* warn with -principal *)
+               ^
+Warning 42: this use of A required disambiguation.
+Characters 20-21:
+  class g = f (A : t) A;; (* warn with -principal *)
+                      ^
+Warning 42: this use of A required disambiguation.
+class g : f
+#                       Characters 199-200:
+    let y : t = {x = 0}
+                 ^
+Warning 42: this use of x required disambiguation.
+Characters 114-120:
+    open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+    ^^^^^^
+Warning 33: unused open M.
+module Shadow1 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : t
+  end
+#               Characters 97-103:
+    open M  (* this open shadows label 'x' *)
+    ^^^^^^
+Warning 45: this open statement shadows the label x (which is later used)
+Characters 149-157:
+    let y = {x = ""}
+            ^^^^^^^^
+Warning 41: these field labels belong to several types: M.s t
+The first one was selected. Please disambiguate if this is wrong.
+module Shadow2 :
+  sig
+    type t = { x : int; }
+    module M : sig type s = { x : string; } end
+    val y : M.s
+  end
+# 
diff --git a/testsuite/tests/utils/Makefile b/testsuite/tests/utils/Makefile
new file mode 100644
index 00000000..4b7ab0dd
--- /dev/null
+++ b/testsuite/tests/utils/Makefile
@@ -0,0 +1,20 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                         Alain Frisch, LexiFi                          #
+#                                                                       #
+#   Copyright 2012 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+MODULES=testing misc
+INCLUDES= -I $(OTOPDIR)/utils
+ADD_COMPFLAGS=$(INCLUDES)
+CMO_FILES+="misc.cmo"
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/utils/edit_distance.ml b/testsuite/tests/utils/edit_distance.ml
new file mode 100644
index 00000000..76eec0ba
--- /dev/null
+++ b/testsuite/tests/utils/edit_distance.ml
@@ -0,0 +1,49 @@
+let edit_distance = Misc.edit_distance
+
+let show_cutoff n =
+  if n = max_int then "max_int" else Printf.sprintf "%d" n
+;;
+
+let test =
+  let counter = ref 0 in
+  fun a b cutoff expected ->
+    let show_result = function
+      | None -> "None"
+      | Some d -> "Some " ^ string_of_int d in
+    incr counter;
+    Printf.printf "[%02d] (edit_distance %S %S %s), expected %s\n"
+      !counter a b (show_cutoff cutoff) (show_result expected);
+    let result = edit_distance a b cutoff in
+    if result = expected
+    then print_endline "OK"
+    else Printf.printf "FAIL: got %s\n%!" (show_result result)
+
+let () =
+  test "a" "a" 1 (Some 0);
+  test "a" "a" 0 (Some 0);
+  test "a" "b" 1 (Some 1);
+  test "a" "b" 0 None;
+  test "add" "adad" 3 (Some 1);
+  test "delete" "delte" 3 (Some 1);
+  test "subst" "sabst" 3 (Some 1);
+  test "swap" "sawp" 3 (Some 1);
+  test "abbb" "bbba" 3 (Some 2);
+  test "abbb" "bbba" 1 None;
+
+  (* check for bugs where a small common suffix, or common prefix, is
+     enough to make the distance goes down *)
+  test "xyzwabc" "mnpqrabc" 10 (Some 5);
+  test "abcxyzw" "abcmnpqr" 10 (Some 5);
+
+  (* check that using "max_int" as cutoff works *)
+  test "a" "a" max_int (Some 0);
+  test "a" "b" max_int (Some 1);
+  test "abc" "ade" max_int (Some 2);
+
+  (* check empty strings*)
+  test "" "" 3 (Some 0);
+  test "" "abc" 3 (Some 3);
+  test "abcd" "" 3 None;
+  
+  ()
+
diff --git a/testsuite/tests/utils/edit_distance.reference b/testsuite/tests/utils/edit_distance.reference
new file mode 100644
index 00000000..c2816dab
--- /dev/null
+++ b/testsuite/tests/utils/edit_distance.reference
@@ -0,0 +1,38 @@
+[01] (edit_distance "a" "a" 1), expected Some 0
+OK
+[02] (edit_distance "a" "a" 0), expected Some 0
+OK
+[03] (edit_distance "a" "b" 1), expected Some 1
+OK
+[04] (edit_distance "a" "b" 0), expected None
+OK
+[05] (edit_distance "add" "adad" 3), expected Some 1
+OK
+[06] (edit_distance "delete" "delte" 3), expected Some 1
+OK
+[07] (edit_distance "subst" "sabst" 3), expected Some 1
+OK
+[08] (edit_distance "swap" "sawp" 3), expected Some 1
+OK
+[09] (edit_distance "abbb" "bbba" 3), expected Some 2
+OK
+[10] (edit_distance "abbb" "bbba" 1), expected None
+OK
+[11] (edit_distance "xyzwabc" "mnpqrabc" 10), expected Some 5
+OK
+[12] (edit_distance "abcxyzw" "abcmnpqr" 10), expected Some 5
+OK
+[13] (edit_distance "a" "a" max_int), expected Some 0
+OK
+[14] (edit_distance "a" "b" max_int), expected Some 1
+OK
+[15] (edit_distance "abc" "ade" max_int), expected Some 2
+OK
+[16] (edit_distance "" "" 3), expected Some 0
+OK
+[17] (edit_distance "" "abc" 3), expected Some 3
+OK
+[18] (edit_distance "abcd" "" 3), expected None
+OK
+
+All tests succeeded.
diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile
index 12d375e4..06f574f1 100644
--- a/testsuite/tests/warnings/Makefile
+++ b/testsuite/tests/warnings/Makefile
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 BASEDIR=../..
 FLAGS=-w A
 EXECNAME=./program
@@ -5,8 +17,10 @@ EXECNAME=./program
 run-all:
 	@for file in *.ml; do \
 	  printf " ... testing '$$file':"; \
-	  $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2> `basename $$file ml`result; \
-	  $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
+	  F="`basename $$file .ml`"; \
+	  $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2>$$F.result; \
+	  $(DIFF) $$F.reference $$F.result >/dev/null \
+	  && echo " => passed" || echo " => failed"; \
 	done;
 
 promote: defaultpromote
diff --git a/testsuite/tests/warnings/w01.ml b/testsuite/tests/warnings/w01.ml
index 08e2f291..24a6accc 100644
--- a/testsuite/tests/warnings/w01.ml
+++ b/testsuite/tests/warnings/w01.ml
@@ -1,3 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Moscova, 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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
 
 (* C *)
 
diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
index 492ec7dc..730da03c 100644
--- a/testsuite/tests/warnings/w01.reference
+++ b/testsuite/tests/warnings/w01.reference
@@ -1,15 +1,15 @@
-File "w01.ml", line 4, characters 12-14:
+File "w01.ml", line 15, characters 12-14:
 Warning 2: this is not the end of a comment.
-File "w01.ml", line 10, characters 0-3:
+File "w01.ml", line 21, characters 0-3:
 Warning 5: this function application is partial,
 maybe some arguments are missing.
-File "w01.ml", line 20, characters 4-5:
+File "w01.ml", line 31, characters 4-5:
 Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 0
-File "w01.ml", line 25, characters 0-1:
+File "w01.ml", line 36, characters 0-1:
 Warning 10: this expression should have type unit.
-File "w01.ml", line 9, characters 8-9:
+File "w01.ml", line 20, characters 8-9:
 Warning 27: unused variable y.
-File "w01.ml", line 32, characters 2-3:
+File "w01.ml", line 43, characters 2-3:
 Warning 11: this match case is unused.
diff --git a/testsuite/typing b/testsuite/typing
new file mode 100644
index 00000000..b2e68dc5
--- /dev/null
+++ b/testsuite/typing
@@ -0,0 +1,22 @@
+tests/typing-fstclassmod
+tests/typing-gadts
+tests/typing-implicit_unpack
+tests/typing-labels
+tests/typing-misc
+tests/typing-modules
+tests/typing-modules-bugs
+tests/typing-objects
+tests/typing-objects-bugs
+tests/typing-poly
+tests/typing-poly-bugs
+tests/typing-polyvariants-bugs
+tests/typing-polyvariants-bugs-2
+tests/typing-private
+tests/typing-private-bugs
+tests/typing-recmod
+tests/typing-rectypes-bugs
+tests/typing-short-paths
+tests/typing-signatures
+tests/typing-sigsubst
+tests/typing-typeparam
+tests/typing-warnings
diff --git a/tools/.depend b/tools/.depend
index c7531b29..9b20d32f 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,21 +1,23 @@
 depend.cmi : ../parsing/parsetree.cmi
 profiling.cmi :
-typedtreeIter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
+tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
 untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \
     ../parsing/parsetree.cmi ../parsing/longident.cmi
 addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
 addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
-cmt2annot.cmo : untypeast.cmi typedtreeIter.cmi ../typing/typedtree.cmi \
-    ../typing/stypes.cmi pprintast.cmo ../typing/path.cmi \
-    ../typing/oprint.cmi ../parsing/location.cmi ../typing/ident.cmi \
-    ../typing/env.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \
+cmt2annot.cmo : untypeast.cmi ../typing/types.cmi ../typing/typedtree.cmi \
+    tast_iter.cmi ../typing/stypes.cmi ../parsing/pprintast.cmi \
+    ../typing/path.cmi ../typing/oprint.cmi ../parsing/location.cmi \
+    ../typing/ident.cmi ../typing/envaux.cmi ../typing/env.cmi \
+    ../utils/config.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \
     ../typing/annot.cmi
-cmt2annot.cmx : untypeast.cmx typedtreeIter.cmx ../typing/typedtree.cmx \
-    ../typing/stypes.cmx pprintast.cmx ../typing/path.cmx \
-    ../typing/oprint.cmx ../parsing/location.cmx ../typing/ident.cmx \
-    ../typing/env.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \
+cmt2annot.cmx : untypeast.cmx ../typing/types.cmx ../typing/typedtree.cmx \
+    tast_iter.cmx ../typing/stypes.cmx ../parsing/pprintast.cmx \
+    ../typing/path.cmx ../typing/oprint.cmx ../parsing/location.cmx \
+    ../typing/ident.cmx ../typing/envaux.cmx ../typing/env.cmx \
+    ../utils/config.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \
     ../typing/annot.cmi
 cvt_emit.cmo :
 cvt_emit.cmx :
@@ -27,14 +29,18 @@ depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
     depend.cmi
 dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
     ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \
-    ../bytecomp/instruct.cmi ../typing/ident.cmi ../bytecomp/emitcode.cmi \
-    ../utils/config.cmi ../bytecomp/cmo_format.cmi \
-    ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi
+    ../bytecomp/instruct.cmi ../typing/ident.cmi ../utils/config.cmi \
+    ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \
+    ../parsing/asttypes.cmi
 dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
     ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \
-    ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \
-    ../utils/config.cmx ../bytecomp/cmo_format.cmi \
-    ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
+    ../bytecomp/instruct.cmx ../typing/ident.cmx ../utils/config.cmx \
+    ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \
+    ../parsing/asttypes.cmi
+eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../parsing/asttypes.cmi
+eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
+    ../parsing/location.cmx ../parsing/asttypes.cmi
 myocamlbuild_config.cmo :
 myocamlbuild_config.cmx :
 objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \
@@ -49,14 +55,14 @@ ocaml299to3.cmo :
 ocaml299to3.cmx :
 ocamlcp.cmo : ../driver/main_args.cmi
 ocamlcp.cmx : ../driver/main_args.cmx
-ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
-    ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \
+ocamldep.cmo : ../parsing/syntaxerr.cmi ../driver/pparse.cmi \
+    ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
     ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \
-    ../utils/config.cmi ../utils/clflags.cmi
-ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
-    ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
+    ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi
+ocamldep.cmx : ../parsing/syntaxerr.cmx ../driver/pparse.cmx \
+    ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
     ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \
-    ../utils/config.cmx ../utils/clflags.cmx
+    ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx
 ocamlmklib.cmo : myocamlbuild_config.cmo
 ocamlmklib.cmx : myocamlbuild_config.cmx
 ocamlmktop.cmo : ../utils/ccomp.cmi
@@ -64,19 +70,13 @@ ocamlmktop.cmx : ../utils/ccomp.cmx
 ocamloptp.cmo : ../driver/main_args.cmi
 ocamloptp.cmx : ../driver/main_args.cmx
 ocamlprof.cmo : ../utils/warnings.cmi ../parsing/syntaxerr.cmi \
-    ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
-    ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \
-    ../utils/clflags.cmi
+    ../parsing/parsetree.cmi ../parsing/parse.cmi ../parsing/location.cmi \
+    ../parsing/lexer.cmi
 ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
-    ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
-    ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \
-    ../utils/clflags.cmx
+    ../parsing/parsetree.cmi ../parsing/parse.cmx ../parsing/location.cmx \
+    ../parsing/lexer.cmx
 opnames.cmo :
 opnames.cmx :
-pprintast.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
-    ../parsing/location.cmi ../parsing/asttypes.cmi
-pprintast.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
-    ../parsing/location.cmx ../parsing/asttypes.cmi
 primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
 primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
 profiling.cmo : profiling.cmi
@@ -85,13 +85,13 @@ read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
 read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
 scrapelabels.cmo :
 scrapelabels.cmx :
-typedtreeIter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi \
-    ../parsing/asttypes.cmi typedtreeIter.cmi
-typedtreeIter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx \
-    ../parsing/asttypes.cmi typedtreeIter.cmi
+tast_iter.cmo : ../typing/typedtree.cmi ../parsing/asttypes.cmi \
+    tast_iter.cmi
+tast_iter.cmx : ../typing/typedtree.cmx ../parsing/asttypes.cmi \
+    tast_iter.cmi
 untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \
-    ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \
-    ../typing/ident.cmi ../parsing/asttypes.cmi untypeast.cmi
+    ../parsing/parsetree.cmi ../parsing/longident.cmi ../typing/ident.cmi \
+    ../parsing/asttypes.cmi untypeast.cmi
 untypeast.cmx : ../typing/typedtree.cmx ../typing/path.cmx \
-    ../parsing/parsetree.cmi ../utils/misc.cmx ../parsing/longident.cmx \
-    ../typing/ident.cmx ../parsing/asttypes.cmi untypeast.cmi
+    ../parsing/parsetree.cmi ../parsing/longident.cmx ../typing/ident.cmx \
+    ../parsing/asttypes.cmi untypeast.cmi
diff --git a/tools/.ignore b/tools/.ignore
index 1ddcc256..ce14846d 100644
--- a/tools/.ignore
+++ b/tools/.ignore
@@ -24,6 +24,5 @@ scrapelabels
 addlabels
 myocamlbuild_config.ml
 objinfo_helper
-objinfo_helper.exe
 read_cmt
-read_cmt.bak
+read_cmt.opt
diff --git a/tools/Makefile b/tools/Makefile
index 9122f6bf..e2f3cb26 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -10,8 +10,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11184 2011-09-07 14:28:24Z xclerc $
-
 include Makefile.shared
 
 # To make custom toplevels
diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index 887976b0..052af81c 100644
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -10,8 +10,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11184 2011-09-07 14:28:24Z xclerc $
-
 include Makefile.shared
 
 # To make custom toplevels
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index f6818d3d..117f5768 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -10,8 +10,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.shared 12526 2012-05-31 12:41:49Z lefessan $
-
 include ../config/Makefile
 
 CAMLRUN=../boot/ocamlrun
@@ -20,16 +18,19 @@ CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
 CAMLLEX=$(CAMLRUN) ../boot/ocamllex
 INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
 	 -I ../driver
-COMPFLAGS= -warn-error A $(INCLUDES)
+COMPFLAGS= -w +32..39 -warn-error A $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
 
 all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
      objinfo read_cmt
+
+all: tast_iter.cmo
+
 # scrapelabels addlabels
 
 .PHONY: all
 
-opt.opt: ocamldep.opt
+opt.opt: ocamldep.opt read_cmt.opt
 .PHONY: opt.opt
 
 # The dependency generator
@@ -37,10 +38,11 @@ opt.opt: ocamldep.opt
 CAMLDEP_OBJ=depend.cmo ocamldep.cmo
 CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo \
-  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo \
+  ccomp.cmo pparse.cmo compenv.cmo
 
 ocamldep: depend.cmi $(CAMLDEP_OBJ)
-	$(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
+	$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
 
 ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx)
 	$(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \
@@ -208,6 +210,7 @@ READ_CMT= \
           ../parsing/location.cmo \
           ../parsing/longident.cmo \
           ../parsing/lexer.cmo \
+          ../parsing/pprintast.cmo \
           ../typing/ident.cmo \
           ../typing/path.cmo \
           ../typing/types.cmo \
@@ -222,17 +225,25 @@ READ_CMT= \
           ../typing/oprint.cmo \
           ../typing/primitive.cmo \
           ../typing/printtyp.cmo \
+          ../typing/mtype.cmo \
+          ../typing/envaux.cmo \
+          ../typing/typedtreeMap.cmo \
+          ../typing/typedtreeIter.cmo \
           ../typing/cmt_format.cmo \
           ../typing/stypes.cmo \
           \
-          pprintast.cmo untypeast.cmo typedtreeIter.cmo  \
+          untypeast.cmo \
+          tast_iter.cmo \
           cmt2annot.cmo read_cmt.cmo
 
 read_cmt: $(READ_CMT)
 	$(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT)
 
+read_cmt.opt: $(READ_CMT:.cmo=.cmx)
+	$(CAMLOPT) $(LINKFLAGS) -o read_cmt.opt $(READ_CMT:.cmo=.cmx)
+
 clean::
-	rm -f read_cmt
+	rm -f read_cmt read_cmt.opt
 
 beforedepend::
 
diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index a098124b..b5361482 100644
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -11,8 +11,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: addlabels.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open StdLabels
 open Asttypes
 open Parsetree
@@ -192,7 +190,8 @@ let rec insert_labels_app ~labels ~text args =
         let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in
         let pos = insertion_point pos0 ~text in
         match arg.pexp_desc with
-        | Pexp_ident({ txt = Longident.Lident name }) when l = name && pos = pos0 ->
+        | Pexp_ident({ txt = Longident.Lident name })
+          when l = name && pos = pos0 ->
             add_insertion pos "~"
         | _ -> add_insertion pos ("~" ^ l ^ ":")
       end;
@@ -226,7 +225,9 @@ let rec add_labels_expr ~text ~values ~classes expr =
       end;
       List.iter args ~f:(fun (_,e) -> add_labels_rec e)
   | Pexp_apply ({pexp_desc=Pexp_send
-                   ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},meth)}, args) ->
+                   ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},
+                    meth)},
+                args) ->
       begin try
         if SMap.find s values = [""] then
           let labels = SMap.find (s ^ "#" ^ meth) values in
diff --git a/tools/check-typo b/tools/check-typo
new file mode 100755
index 00000000..05c7c68c
--- /dev/null
+++ b/tools/check-typo
@@ -0,0 +1,232 @@
+#!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#           Damien Doligez, projet Gallium, INRIA Rocquencourt          #
+#                                                                       #
+#   Copyright 2012 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# check-typo - Check typographic conventions on OCaml sources.
+
+# This program will check files for the following rules:
+
+# - absence of TAB characters (tab)
+# - absence of non-ASCII characters (non-ascii)
+# - absence of non-printing ASCII characters (non-printing)
+# - absence of white space at end of line (white-at-eol)
+# - absence of empty lines at end of file (white-at-eof)
+# - presence of a LF character at the end of the file (missing-lf)
+# - maximum line length of 80 characters (long-line)
+# - presence of a copyright header (missing-header)
+# - absence of a leftover "$Id" string (svn-keyword)
+
+# Exceptions are handled with a SVN property: "ocaml:typo".
+# Its value for a given file is a comma-separated list of rule names,
+# which lists the rules that should be disabled for this file.
+# The rule names are the ones shown above in parentheses.
+
+# Built-in exceptions:
+# - Any binary file (i.e. with svn:mime-type = application/octet-stream)
+#   is automatically exempt from all the rules.
+# - Any file whose name begins with "Makefile" is automatically exempt
+#   from the "tabs" rule.
+# - Any file whose name matches one of the following patterns is
+#   automatically exempt from the "missing-header" rule.
+#     */.depend*
+#     */.ignore
+#     *.mlpack
+#     *.mllib
+#     *.mltop
+#     *.odocl
+#     *.clib
+#     *.reference
+#     */reference
+# - Any file whose name matches one of the following patterns is
+#   automatically exempt from the "long-line" rule.
+#     *.reference
+
+# ASCII characters are bytes from 0 to 127.  Any other byte is
+# flagged as a non-ASCII character.
+
+# For the purpose of this tool, printing ASCII characters are:
+# - the non-white printable ASCII characters (33 to 126)
+# - TAB (09)
+# - LF (10)
+# - SPC (32)
+# Anything else is flagged as a non-printing ASCII character.
+
+# This program will recursively explore the files and directories given
+# on the command line (or by default the current directory), and check
+# every file therein for compliance to the rules.
+
+# Directories named .svn and _build (and their contents) are always ignored.
+# This program ignores any file that is not under svn control, unless
+# explicitly given on the command line.
+
+# If a directory has the SVN property "ocaml:typo" set to "prune",
+# then it and its contents are ignored.
+
+# You can ignore a rule by giving the option - on the command
+# line (before any file names).
+
+# Special case for recursive call from the find command (see IGNORE_DIRS).
+case "$1" in
+  --check-prune)
+    case `svn propget ocaml:typo "$2" 2>/dev/null` in
+      prune) echo "INFO: pruned directory $2 (ocaml:typo=prune)" >&2; exit 0;;
+      *) exit 3;;
+    esac;;
+esac
+
+usage () {
+  echo "usage: check-typo {-} [--] {}" >&2
+  exit 2
+}
+
+userrules=''
+
+while : ; do
+  case "$1" in
+    -help|--help) usage;;
+    -*) userrules="${1#-},$userrules"; shift;;
+    --) shift; break;;
+    *) break;;
+  esac
+done
+
+IGNORE_DIRS="
+  -name .svn -prune -o
+  -name _build -prune -o
+  -type d -exec $0 --check-prune {} ; -prune -o
+"
+
+( case $# in
+    0) find . $IGNORE_DIRS -type f -print;;
+    *) for i in "$@"; do find "$i" $IGNORE_DIRS -type f -print; done;;
+  esac
+) | (
+  while read f; do
+    case `svn status "$f" 2>&1` in
+      '?'*) is_svn=false;;
+      I*) is_svn=false;;
+      svn:*"is not a working copy") is_svn=false;;
+      *) is_svn=true;;
+    esac
+    case "$*" in
+      *$f*) is_cmd_line=true;;
+      *) is_cmd_line=false;;
+    esac
+    if $is_svn || $is_cmd_line; then :; else continue; fi
+    svnrules=''
+    if $is_svn; then
+      case `svn propget svn:mime-type "$f"` in
+        application/octet-stream) continue;;
+      esac
+      svnrules=`svn propget ocaml:typo "$f"`
+    fi
+    rules="$userrules"
+    case "$f" in
+      Makefile*|*/Makefile*) rules="tab,$rules";;
+    esac
+    h(){ rules="missing-header,$rules"; }
+    case "$f" in
+      */.depend*|*/.ignore) h;;
+      *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;;
+      *.reference|*/reference) h;;
+    esac
+    case "$f" in
+      *.reference) rules="long-line,$rules";;
+    esac
+
+    (cat "$f"; echo) \
+    | awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \
+      '
+        function err(name, msg) {
+          ++ counts[name];
+          if (("," rules svnrules ",") !~ ("[, ]" name "[, ]") \
+              && counts[name] <= 10){
+            printf ("%s:%d.%d:", file, NR, RSTART + RLENGTH);
+            printf (" [%s] %s\n", name, msg);
+            if (counts[name] == 10){
+              printf ("WARNING: too many [%s] in this file.", name);
+              printf ("  Others will not be reported.\n");
+            }
+          }
+        }
+
+        match($0, /\t/) {
+          err("tab", "TAB character(s)");
+        }
+
+        match($0, /[\200-\377]/) {
+          err("non-ascii", "non-ASCII character(s)");
+        }
+
+        match($0, /[^\t\200-\377 -~]/) {
+          err("non-printing", "non-printing ASCII character(s)");
+        }
+
+        match($0, /[ \t]+$/) {
+          err("white-at-eol", "whitespace at end of line");
+        }
+
+        match($0, /\$Id(: .*)?\$/) {
+          err("svn-keyword", "SVN keyword marker");
+        }
+
+        length($0) > 80 {
+          RSTART = 81;
+          RLENGTH = 0;
+          err("long-line", "line is over 80 characters");
+        }
+
+        3 <= NR && NR <= 5 \
+        && (/ OCaml / || / ocamlbuild / || / OCamldoc /) {
+          header_ocaml = NR;
+        }
+
+        header_ocaml && header_ocaml + 4 <= NR && NR <= header_ocaml + 6 \
+        && / Copyright / {
+          header_copyright = 1;
+        }
+
+        {
+          prev_line = last_line;
+          last_line = $0;
+        }
+
+        END {
+          if (match(last_line, /.+/)){
+            err("missing-lf", "missing linefeed at EOF");
+            prev_line = last_line;
+            ++ NR;
+            empty_file = 0;
+          }else{
+            empty_file = NR == 1;
+          }
+          if (!empty_file && match(prev_line, /^$/)){
+            err("white-at-eof", "empty line(s) at EOF");
+          }
+          NR = 1;
+          RSTART = 1;
+          RLENGTH = 0;
+          if (!(header_ocaml && header_copyright)){
+            err("missing-header", "missing copyright header");
+          }
+          split(svnrules, r, "[, ]");
+          for (i in r){
+            name = r[i];
+            if (name != "" && !counts[name]){
+              err("unused-prop", sprintf("unused [%s] in ocaml:typo", name));
+            }
+          }
+        }
+      '
+  done
+)
diff --git a/tools/checkstack.c b/tools/checkstack.c
index 3e0a8002..dea6a0a6 100644
--- a/tools/checkstack.c
+++ b/tools/checkstack.c
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: checkstack.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
index 917ab2ff..fd2a6c95 100644
--- a/tools/cmt2annot.ml
+++ b/tools/cmt2annot.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Fabrice Le Fessant, INRIA Saclay                   *)
 (*                                                                     *)
@@ -9,253 +9,158 @@
 (*  under the terms of the Q Public License version 1.0.               *)
 (*                                                                     *)
 (***********************************************************************)
-(*
-Generate .annot file from a .types files.
-*)
 
-open Typedtree
-open TypedtreeIter
-
-let pattern_scopes = ref []
-
-let push_None () =
-  pattern_scopes := None :: !pattern_scopes
-let push_Some annot =
-  pattern_scopes := (Some annot) :: !pattern_scopes
-let pop_scope () =
-  match !pattern_scopes with
-    [] -> assert false
-  | _ :: scopes -> pattern_scopes := scopes
-
-module ForIterator = struct
-    open Asttypes
-
-    include DefaultIteratorArgument
-
-    let structure_begin_scopes = ref []
-    let structure_end_scopes = ref []
-
-    let rec find_last list =
-      match list with
-        [] -> assert false
-      | [x] -> x
-      | _ :: tail -> find_last tail
-
-    let enter_structure str =
-      match str.str_items with
-        [] -> ()
-      | _ ->
-          let loc =
-            match !structure_end_scopes with
-              [] -> Location.none
-            | _ ->
-                let s = find_last str.str_items in
-                s.str_loc
-          in
-          structure_end_scopes := loc :: !structure_end_scopes;
-
-          let rec iter list =
-            match list with
-              [] -> assert false
-            | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] ->
-                structure_begin_scopes := loc.Location.loc_end
-                  :: !structure_begin_scopes
-            | [ _ ] -> ()
-            | item :: tail ->
-                iter tail;
-                match item, tail with
-                  { str_desc = Tstr_value (Nonrecursive,_) },
-                  { str_loc = loc } :: _ ->
-                    structure_begin_scopes := loc.Location.loc_start
-                      :: !structure_begin_scopes
-                | _ -> ()
-          in
-          iter str.str_items
-
-    let leave_structure str =
-      match str.str_items with
-        [] -> ()
-      | _ ->
-          match !structure_end_scopes with
-            [] -> assert false
-          | _ :: scopes -> structure_end_scopes := scopes
+(* Generate an .annot file from a .cmt file. *)
 
-    let enter_class_expr node =
-      Stypes.record (Stypes.Ti_class node)
-    let enter_module_expr node =
-      Stypes.record (Stypes.Ti_mod node)
+open Asttypes
+open Typedtree
 
-    let add_variable pat id =
-      match !pattern_scopes with
-      | [] -> assert false
-      | None :: _ -> ()
-      | (Some s) :: _ ->
-          Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s))
+let bind_variables scope =
+  object
+    inherit Tast_iter.iter as super
 
-    let enter_pattern pat =
+    method! pattern pat =
+      super # pattern pat;
       match pat.pat_desc with
-      | Tpat_var (id, _)
-      | Tpat_alias (_, id,_)
-        -> add_variable pat id
-      | Tpat_any -> ()
-      | Tpat_constant _
-      | Tpat_tuple _
-      | Tpat_construct _
-      | Tpat_lazy _
-      | Tpat_or _
-      | Tpat_array _
-      | Tpat_record _
-      | Tpat_variant _
-        -> ()
-
-    let leave_pattern pat =
-      Stypes.record (Stypes.Ti_pat pat)
-
-    let rec name_of_path = function
-      | Path.Pident id -> Ident.name id
-      | Path.Pdot(p, s, pos) ->
-          if Oprint.parenthesized_ident s then
-            name_of_path p ^ ".( " ^ s ^ " )"
-          else
-            name_of_path p ^ "." ^ s
-      | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")"
+      | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+          Stypes.record (Stypes.An_ident (pat.pat_loc,
+                                          Ident.name id,
+                                          Annot.Idef scope))
+      | _ -> ()
+  end
 
-    let enter_expression exp =
-      match exp.exp_desc with
-        Texp_ident (path, _, _) ->
-          let full_name = name_of_path path in
-          begin
+let bind_bindings scope bindings =
+  let o = bind_variables scope in
+  List.iter (fun (p, _) -> o # pattern p) bindings
+
+let bind_cases l =
+  List.iter (fun (p, e) -> (bind_variables e.exp_loc) # pattern p) l
+
+let iterator rebuild_env =
+  object(this)
+    val scope = Location.none  (* scope of the surrounding structure *)
+
+    inherit Tast_iter.iter as super
+
+    method! class_expr node =
+      Stypes.record (Stypes.Ti_class node);
+      super # class_expr node
+
+    method! module_expr node =
+      Stypes.record (Stypes.Ti_mod node);
+      Tast_iter.module_expr {< scope = node.mod_loc >} node
+
+    method! expression exp =
+      begin match exp.exp_desc with
+      | Texp_ident (path, _, _) ->
+          let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
+          let env =
+            if rebuild_env then
+              try
+                Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
+              with Envaux.Error err ->
+                Format.eprintf "%a@." Envaux.report_error err;
+                exit 2
+            else
+              exp.exp_env
+          in
+          let annot =
             try
-              let annot = Env.find_annot path exp.exp_env in
-              Stypes.record
-                (Stypes.An_ident (exp.exp_loc, full_name , annot))
+              let desc = Env.find_value path env in
+              let dloc = desc.Types.val_loc in
+              if dloc.Location.loc_ghost then Annot.Iref_external
+              else Annot.Iref_internal dloc
             with Not_found ->
-              Stypes.record
-                (Stypes.An_ident (exp.exp_loc, full_name , Annot.Iref_external))
-          end
-
-      | Texp_let (rec_flag, _, body) ->
-          begin
-            match rec_flag with
-            | Recursive -> push_Some (Annot.Idef exp.exp_loc)
-            | Nonrecursive -> push_Some (Annot.Idef body.exp_loc)
-            | Default -> push_None ()
-          end
-      | Texp_function _ -> push_None ()
-      | Texp_match _ -> push_None ()
-      | Texp_try _ -> push_None ()
-      | _ -> ()
-
-    let leave_expression exp =
-      if not exp.exp_loc.Location.loc_ghost then
-        Stypes.record (Stypes.Ti_expr exp);
-      match exp.exp_desc with
-      | Texp_let _
-      | Texp_function _
-      | Texp_match _
-      | Texp_try _
-        -> pop_scope ()
-      | _ -> ()
-
-    let enter_binding pat exp =
-      let scope =
-        match !pattern_scopes with
-        | [] -> assert false
-        | None :: _ -> Some (Annot.Idef exp.exp_loc)
-        | scope :: _ -> scope
-      in
-      pattern_scopes := scope :: !pattern_scopes
-
-    let leave_binding _ _ =
-      pop_scope ()
-
-    let enter_class_expr exp =
-      match exp.cl_desc with
-      | Tcl_fun _ -> push_None ()
-      | Tcl_let _ -> push_None ()
-      | _ -> ()
-
-    let leave_class_expr exp =
-      match exp.cl_desc with
-      | Tcl_fun _
-      | Tcl_let _ -> pop_scope ()
-      | _ -> ()
-
-    let enter_class_structure _ =
-      push_None ()
-
-    let leave_class_structure _ =
-      pop_scope ()
-
-(*
-    let enter_class_field cf =
-      match cf.cf_desc with
-        Tcf_let _ -> push_None ()
+              Annot.Iref_external
+          in
+          Stypes.record
+            (Stypes.An_ident (exp.exp_loc, full_name , annot))
+      | Texp_let (Recursive, bindings, _) ->
+          bind_bindings exp.exp_loc bindings
+      | Texp_let (Nonrecursive, bindings, body) ->
+          bind_bindings body.exp_loc bindings
+      | Texp_function (_, f, _)
+      | Texp_match (_, f, _)
+      | Texp_try (_, f) ->
+          bind_cases f
       | _ -> ()
+      end;
+      Stypes.record (Stypes.Ti_expr exp);
+      super # expression exp
 
-    let leave_class_field cf =
-      match cf.cf_desc with
-        Tcf_let _ -> pop_scope ()
-      | _ -> ()
-*)
+    method! pattern pat =
+      super # pattern pat;
+      Stypes.record (Stypes.Ti_pat pat)
 
-    let enter_structure_item s =
-      Stypes.record_phrase s.str_loc;
-      match s.str_desc with
-        Tstr_value (rec_flag, _) ->
-          begin
-            let loc = s.str_loc in
-            let scope = match !structure_end_scopes with
-                [] -> assert false
-              | scope :: _ -> scope
-            in
-            match rec_flag with
-            | Recursive -> push_Some
-                  (Annot.Idef { scope with
-                    Location.loc_start = loc.Location.loc_start})
-            | Nonrecursive ->
-(* TODO: do it lazily, when we start the next element ! *)
-(*
-                 let start = match srem with
-                  | [] -> loc.Location.loc_end
-                  | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
-in  *)
-                let start =
-                  match !structure_begin_scopes with
-                    [] -> assert false
-                  | loc :: tail ->
-                      structure_begin_scopes := tail;
-                      loc
-                in
-                push_Some (Annot.Idef {scope with Location.loc_start = start})
-            | Default -> push_None ()
+    method private structure_item_rem s rem =
+      begin match s with
+      | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} ->
+          let open Location in
+          let doit loc_start = bind_bindings {scope with loc_start} bindings in
+          begin match rec_flag, rem with
+          | Default, _ -> ()
+          | Recursive, _ -> doit loc.loc_start
+          | Nonrecursive, [] -> doit loc.loc_end
+          | Nonrecursive,  {str_loc = loc2} :: _ -> doit loc2.loc_start
           end
-      | _ -> ()
-
-    let leave_structure_item s =
-      match s.str_desc with
-        Tstr_value _ -> pop_scope ()
-      | _ -> ()
-
+      | _ ->
+          ()
+      end;
+      Stypes.record_phrase s.str_loc;
+      super # structure_item s
+
+    method! structure_item s =
+      (* This will be used for Partial_structure_item.
+         We don't have here the location of the "next" item,
+         this will give a slightly different scope for the non-recursive
+         binding case. *)
+      this # structure_item_rem s []
+
+    method! structure l =
+      let rec loop = function
+        | str :: rem -> this # structure_item_rem str rem; loop rem
+        | [] -> ()
+      in
+      loop l.str_items
 
+(* TODO: support binding for Tcl_fun, Tcl_let, etc *)
   end
 
-module Iterator = MakeIterator(ForIterator)
-
-let gen_annot target_filename filename cmt =
-  match cmt.Cmt_format.cmt_annots with
-      Cmt_format.Implementation typedtree ->
-        Iterator.iter_structure typedtree;
-        let target_filename = match target_filename with
-            None -> Some (filename ^ ".annot")
-          | Some "-" -> None
-          | Some filename -> target_filename
-        in
-        Stypes.dump target_filename
-    | Cmt_format.Interface _ ->
-      Printf.fprintf stderr "Cannot generate annotations for interface file\n%!";
+let binary_part iter x =
+  let open Cmt_format in
+  match x with
+  | Partial_structure x -> iter # structure x
+  | Partial_structure_item x -> iter # structure_item x
+  | Partial_expression x -> iter # expression x
+  | Partial_pattern x -> iter # pattern x
+  | Partial_class_expr x -> iter # class_expr x
+  | Partial_signature x -> iter # signature x
+  | Partial_signature_item x -> iter # signature_item x
+  | Partial_module_type x -> iter # module_type x
+
+let gen_annot target_filename filename
+              {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} =
+  let open Cmt_format in
+  Envaux.reset_cache ();
+  Config.load_path := cmt_loadpath;
+  let target_filename =
+    match target_filename with
+    | None -> Some (filename ^ ".annot")
+    | Some "-" -> None
+    | Some filename -> target_filename
+  in
+  let iterator = iterator cmt_use_summaries in
+  match cmt_annots with
+  | Implementation typedtree ->
+      iterator # structure typedtree;
+      Stypes.dump target_filename
+  | Interface _ ->
+      Printf.eprintf "Cannot generate annotations for interface file\n%!";
       exit 2
-    | _ ->
+  | Partial_implementation parts ->
+      Array.iter (binary_part iterator) parts;
+      Stypes.dump target_filename
+  | _ ->
       Printf.fprintf stderr "File was generated with an error\n%!";
       exit 2
 
@@ -265,9 +170,9 @@ let gen_ml target_filename filename cmt =
   let (printer, ext) =
     match cmt.Cmt_format.cmt_annots with
       | Cmt_format.Implementation typedtree ->
-        (fun ppf -> Pprintast.print_structure ppf (Untypeast.untype_structure typedtree)), ".ml"
+        (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml"
       | Cmt_format.Interface typedtree ->
-        (fun ppf -> Pprintast.print_signature ppf (Untypeast.untype_signature typedtree)), ".mli"
+        (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli"
       | _ ->
         Printf.fprintf stderr "File was generated with an error\n%!";
         exit 2
diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll
index 86853b96..d54243e2 100644
--- a/tools/cvt_emit.mll
+++ b/tools/cvt_emit.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: cvt_emit.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
 {
 let first_item = ref false
 let command_beginning = ref 0
@@ -59,7 +57,8 @@ and command = parse
           command lexbuf }
   | ( [^ '`' '{' '\\'] |
       '\\' ['\\' '"' 'n' 't' 'b' 'r' '`' '{' ] |
-      '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] ) +
+      '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] |
+      '\\' ('\n' | "\r\n")) +
         { let s = Lexing.lexeme lexbuf in
           add_semicolon();
           (* Optimise one-character strings *)
diff --git a/tools/depend.ml b/tools/depend.ml
index 3c37c132..328ca49e 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -10,10 +10,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: depend.ml 12883 2012-08-25 11:35:20Z garrigue $ *)
-
 open Asttypes
-open Format
 open Location
 open Longident
 open Parsetree
@@ -22,8 +19,6 @@ module StringSet = Set.Make(struct type t = string let compare = compare end)
 
 (* Collect free module identifiers in the a.s.t. *)
 
-let fst3 (x, _, _) = x
-
 let free_structure_names = ref StringSet.empty
 
 let rec addmodule bv lid =
@@ -77,10 +72,13 @@ let add_type_declaration bv td =
     (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
     td.ptype_cstrs;
   add_opt add_type bv td.ptype_manifest;
-  let rec add_tkind = function
+  let add_tkind = function
     Ptype_abstract -> ()
   | Ptype_variant cstrs ->
-      List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
+      List.iter (fun (c, args, rty, _) ->
+                   List.iter (add_type bv) args;
+                   Misc.may (add_type bv) rty)
+                cstrs
   | Ptype_record lbls ->
       List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
   add_tkind td.ptype_kind
@@ -179,7 +177,7 @@ let rec add_expr bv exp =
       let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
   | Pexp_newtype (_, e) -> add_expr bv e
   | Pexp_pack m -> add_module bv m
-  | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
+  | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e
 
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel
@@ -221,7 +219,9 @@ and add_sig_item bv item =
   | Psig_module(id, mty) ->
       add_modtype bv mty; StringSet.add id.txt bv
   | Psig_recmodule decls ->
-      let bv' = List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv in
+      let bv' =
+         List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv
+      in
       List.iter (fun (id, mty) -> add_modtype bv' mty) decls;
       bv'
   | Psig_modtype(id,mtyd) ->
@@ -230,7 +230,7 @@ and add_sig_item bv item =
       | Pmodtype_manifest mty -> add_modtype bv mty
       end;
       bv
-  | Psig_open lid ->
+  | Psig_open (_ovf, lid) ->
       addmodule bv lid; bv
   | Psig_include mty ->
       add_modtype bv mty; bv
@@ -282,7 +282,7 @@ and add_struct_item bv item =
       bv'
   | Pstr_modtype(id, mty) ->
       add_modtype bv mty; bv
-  | Pstr_open l ->
+  | Pstr_open (_ovf, l) ->
       addmodule bv l; bv
   | Pstr_class cdl ->
       List.iter (add_class_declaration bv) cdl; bv
@@ -294,6 +294,9 @@ and add_struct_item bv item =
 and add_use_file bv top_phrs =
   ignore (List.fold_left add_top_phrase bv top_phrs)
 
+and add_implementation bv l =
+  ignore (add_structure bv l)
+
 and add_top_phrase bv = function
   | Ptop_def str -> add_structure bv str
   | Ptop_dir (_, _) -> bv
diff --git a/tools/depend.mli b/tools/depend.mli
index 196827ba..f859cfef 100644
--- a/tools/depend.mli
+++ b/tools/depend.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: depend.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (** Module dependencies. *)
 
 module StringSet : Set.S with type elt = string
@@ -21,3 +19,5 @@ val free_structure_names : StringSet.t ref
 val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit
 
 val add_signature : StringSet.t -> Parsetree.signature -> unit
+
+val add_implementation : StringSet.t -> Parsetree.structure -> unit
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 82d53e79..b2af7884 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -10,17 +10,13 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: dumpobj.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Disassembler for executable and .cmo object files *)
 
 open Asttypes
 open Config
-open Emitcode
 open Instruct
 open Lambda
 open Location
-open Obj
 open Opcodes
 open Opnames
 open Cmo_format
@@ -452,7 +448,7 @@ let print_instr ic =
         let nvars = inputu ic in
         let orig = currpc ic in
         print_int nvars;
-        for i = 0 to nfuncs - 1 do
+        for _i = 0 to nfuncs - 1 do
           print_string ", ";
           print_int (orig + inputs ic);
         done;
@@ -532,7 +528,7 @@ let dump_exe ic =
   begin try
     ignore (Bytesections.seek_section ic "DBUG");
     let num_eventlists = input_binary_int ic in
-    for i = 1 to num_eventlists do
+    for _i = 1 to num_eventlists do
       let orig = input_binary_int ic in
       let evl = (input_value ic : debug_event list) in
       record_events orig evl
@@ -545,7 +541,9 @@ let dump_exe ic =
 let arg_list = [
   "-noloc", Arg.Clear print_locations, " : don't print source information";
 ]
-let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" Sys.argv.(0)
+let arg_usage =
+  Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"
+                 Sys.argv.(0)
 
 let first_file = ref true
 
diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml
new file mode 100644
index 00000000..10d631f0
--- /dev/null
+++ b/tools/eqparsetree.ml
@@ -0,0 +1,779 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*    Hongbo Zhang (University of Pennsylvania)                           *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*   en Automatique.  All rights reserved.  This file is distributed      *)
+(*   under the terms of the Q Public License version 1.0.                 *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(*
+  This module is mainly used to diff two parsetree, it helps to automate the
+  test for parsing/pprintast.ml
+ *)
+
+
+open Parsetree
+let curry f (g, h) = f g h
+let eq_int : (int*int)->bool = curry (=)
+let eq_char : (char*char)->bool=curry (=)
+let eq_string : (string*string)->bool = curry (=)
+let eq_int32 : (int32*int32)->bool=curry (=)
+let eq_int64 : (int64*int64)->bool =curry (=)
+let eq_nativeint : (nativeint*nativeint)->bool= curry (=)
+let eq_bool :(bool*bool) -> bool = curry (=)
+let eq_list mf_a (xs, ys) =
+  let rec loop =
+    function
+      | ([], []) -> true
+        | (x :: xs, y :: ys) -> (mf_a (x, y)) && (loop (xs, ys))
+        | (_, _) -> false
+  in loop (xs, ys)
+let eq_option mf_a (x, y) =
+  match (x, y) with
+  | (None, None) -> true
+  | (Some x, Some y) -> mf_a (x, y)
+  | (_, _) -> false
+
+module Location =struct
+  include Location
+  let eq_t : (t*t) -> bool = fun (_,_) -> true
+end
+module Longident = struct
+  include Longident
+  let rec eq_t : (t * t) -> 'result =
+    function
+    | (Lident a0, Lident b0) -> eq_string (a0, b0)
+    | (Ldot (a0, a1), Ldot (b0, b1)) ->
+      (eq_t (a0, b0)) && (eq_string (a1, b1))
+    | (Lapply (a0, a1), Lapply (b0, b1)) ->
+      (eq_t (a0, b0)) && (eq_t (a1, b1))
+    | (_, _) -> false
+end
+module Asttypes = struct
+  open Asttypes
+  let eq_constant : (constant * constant) -> 'result =
+    function
+    | (Const_int a0, Const_int b0) -> eq_int (a0, b0)
+    | (Const_char a0, Const_char b0) -> eq_char (a0, b0)
+    | (Const_string a0, Const_string b0) -> eq_string (a0, b0)
+    | (Const_float a0, Const_float b0) -> eq_string (a0, b0)
+    | (Const_int32 a0, Const_int32 b0) -> eq_int32 (a0, b0)
+    | (Const_int64 a0, Const_int64 b0) -> eq_int64 (a0, b0)
+    | (Const_nativeint a0, Const_nativeint b0) -> eq_nativeint (a0, b0)
+    | (_, _) -> false
+
+  let eq_rec_flag : (rec_flag * rec_flag) -> 'result =
+    function
+    | (Nonrecursive, Nonrecursive) -> true
+    | (Recursive, Recursive) -> true
+    | (Default, Default) -> true
+    | (_, _) -> false
+
+  let eq_direction_flag :
+    (direction_flag * direction_flag) -> 'result =
+    function
+    | (Upto, Upto) -> true
+    | (Downto, Downto) -> true
+    | (_, _) -> false
+
+  let eq_private_flag : (private_flag * private_flag) -> 'result =
+    function
+    | (Private, Private) -> true
+    | (Public, Public) -> true
+    | (_, _) -> false
+
+  let eq_mutable_flag : (mutable_flag * mutable_flag) -> 'result =
+    function
+    | (Immutable, Immutable) -> true
+    | (Mutable, Mutable) -> true
+    | (_, _) -> false
+
+  let eq_virtual_flag : (virtual_flag * virtual_flag) -> 'result =
+    function
+    | (Virtual, Virtual) -> true
+    | (Concrete, Concrete) -> true
+    | (_, _) -> false
+
+  let eq_override_flag : (override_flag * override_flag) -> 'result =
+    function
+    | (Override, Override) -> true
+    | (Fresh, Fresh) -> true
+    | (_, _) -> false
+
+  let eq_closed_flag : (closed_flag * closed_flag) -> 'result =
+    function
+    | (Closed, Closed) -> true
+    | (Open, Open) -> true
+    | (_, _) -> false
+
+  let eq_label : (label * label) -> 'result =
+    fun (a0, a1) -> eq_string (a0, a1)
+
+  let  eq_loc :
+    'all_a0.
+      (('all_a0 * 'all_a0) -> 'result) ->
+        (('all_a0 loc) * ('all_a0 loc)) -> 'result =
+    fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) ->
+      (mf_a (a0, b0)) && (Location.eq_t (a1, b1))
+    
+end
+
+let rec eq_row_field : (row_field * row_field) -> 'result =
+  function
+  | (Rtag (a0, a1, a2), Rtag (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_bool (a1, b1))) &&
+        (eq_list eq_core_type (a2, b2))
+  | (Rinherit a0, Rinherit b0) -> eq_core_type (a0, b0)
+  | (_, _) -> false
+and eq_core_field_desc :
+  (core_field_desc * core_field_desc) -> 'result =
+  function
+  | (Pfield (a0, a1), Pfield (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_core_type (a1, b1))
+  | (Pfield_var, Pfield_var) -> true
+  | (_, _) -> false
+and eq_core_field_type :
+  (core_field_type * core_field_type) -> 'result =
+  fun
+    ({ pfield_desc = a0; pfield_loc = a1 },
+     { pfield_desc = b0; pfield_loc = b1 })
+    -> (eq_core_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_package_type : (package_type * package_type) -> 'result =
+  fun (a0, a1) ->
+    (fun ((a0, a1), (b0, b1)) ->
+       (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+                 (eq_core_type (a1, b1)))
+            (a1, b1)))
+      (a0, a1)
+and eq_core_type_desc :
+  (core_type_desc * core_type_desc) -> 'result =
+  function
+  | (Ptyp_any, Ptyp_any) -> true
+  | (Ptyp_var a0, Ptyp_var b0) -> eq_string (a0, b0)
+  | (Ptyp_arrow (a0, a1, a2), Ptyp_arrow (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+        (eq_core_type (a2, b2))
+  | (Ptyp_tuple a0, Ptyp_tuple b0) -> eq_list eq_core_type (a0, b0)
+  | (Ptyp_constr (a0, a1), Ptyp_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Ptyp_object a0, Ptyp_object b0) ->
+      eq_list eq_core_field_type (a0, b0)
+  | (Ptyp_class (a0, a1, a2), Ptyp_class (b0, b1, b2)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_list eq_core_type (a1, b1)))
+        && (eq_list Asttypes.eq_label (a2, b2))
+  | (Ptyp_alias (a0, a1), Ptyp_alias (b0, b1)) ->
+      (eq_core_type (a0, b0)) && (eq_string (a1, b1))
+  | (Ptyp_variant (a0, a1, a2), Ptyp_variant (b0, b1, b2)) ->
+      ((eq_list eq_row_field (a0, b0)) && (eq_bool (a1, b1))) &&
+        (eq_option (eq_list Asttypes.eq_label) (a2, b2))
+  | (Ptyp_poly (a0, a1), Ptyp_poly (b0, b1)) ->
+      (eq_list eq_string (a0, b0)) && (eq_core_type (a1, b1))
+  | (Ptyp_package a0, Ptyp_package b0) -> eq_package_type (a0, b0)
+  | (_, _) -> false
+and eq_core_type : (core_type * core_type) -> 'result =
+  fun
+    ({ ptyp_desc = a0; ptyp_loc = a1 },
+     { ptyp_desc = b0; ptyp_loc = b1 })
+    -> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+  
+let eq_class_infos :
+  'all_a0.
+    (('all_a0 * 'all_a0) -> 'result) ->
+      (('all_a0 class_infos) * ('all_a0 class_infos)) -> 'result =
+  fun mf_a
+    ({
+       pci_virt = a0;
+       pci_params = a1;
+       pci_name = a2;
+       pci_expr = a3;
+       pci_variance = a4;
+       pci_loc = a5
+     },
+     {
+       pci_virt = b0;
+       pci_params = b1;
+       pci_name = b2;
+       pci_expr = b3;
+       pci_variance = b4;
+       pci_loc = b5
+     })
+    ->
+    (((((Asttypes.eq_virtual_flag (a0, b0)) &&
+          ((fun ((a0, a1), (b0, b1)) ->
+              (eq_list (Asttypes.eq_loc eq_string) (a0, b0)) &&
+                (Location.eq_t (a1, b1)))
+             (a1, b1)))
+         && (Asttypes.eq_loc eq_string (a2, b2)))
+        && (mf_a (a3, b3)))
+       &&
+       (eq_list
+          (fun ((a0, a1), (b0, b1)) ->
+             (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+          (a4, b4)))
+      && (Location.eq_t (a5, b5))
+  
+let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result =
+  function
+  | (Ppat_any, Ppat_any) -> true
+  | (Ppat_var a0, Ppat_var b0) -> Asttypes.eq_loc eq_string (a0, b0)
+  | (Ppat_alias (a0, a1), Ppat_alias (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (Asttypes.eq_loc eq_string (a1, b1))
+  | (Ppat_constant a0, Ppat_constant b0) ->
+      Asttypes.eq_constant (a0, b0)
+  | (Ppat_tuple a0, Ppat_tuple b0) -> eq_list eq_pattern (a0, b0)
+  | (Ppat_construct (a0, a1, a2), Ppat_construct (b0, b1, b2)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_option eq_pattern (a1, b1)))
+        && (eq_bool (a2, b2))
+  | (Ppat_variant (a0, a1), Ppat_variant (b0, b1)) ->
+      (Asttypes.eq_label (a0, b0)) && (eq_option eq_pattern (a1, b1))
+  | (Ppat_record (a0, a1), Ppat_record (b0, b1)) ->
+      (eq_list
+         (fun ((a0, a1), (b0, b1)) ->
+            (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+              (eq_pattern (a1, b1)))
+         (a0, b0))
+        && (Asttypes.eq_closed_flag (a1, b1))
+  | (Ppat_array a0, Ppat_array b0) -> eq_list eq_pattern (a0, b0)
+  | (Ppat_or (a0, a1), Ppat_or (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (eq_pattern (a1, b1))
+  | (Ppat_constraint (a0, a1), Ppat_constraint (b0, b1)) ->
+      (eq_pattern (a0, b0)) && (eq_core_type (a1, b1))
+  | (Ppat_type a0, Ppat_type b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Ppat_lazy a0, Ppat_lazy b0) -> eq_pattern (a0, b0)
+  | (Ppat_unpack a0, Ppat_unpack b0) ->
+      Asttypes.eq_loc eq_string (a0, b0)
+  | (_, _) -> false
+and eq_pattern : (pattern * pattern) -> 'result =
+  fun
+    ({ ppat_desc = a0; ppat_loc = a1 },
+     { ppat_desc = b0; ppat_loc = b1 })
+    -> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1))
+  
+let rec eq_structure_item_desc :
+  (structure_item_desc * structure_item_desc) -> 'result =
+  function
+  | (Pstr_eval a0, Pstr_eval b0) -> eq_expression (a0, b0)
+  | (Pstr_value (a0, a1), Pstr_value (b0, b1)) ->
+      (Asttypes.eq_rec_flag (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pstr_primitive (a0, a1), Pstr_primitive (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_value_description (a1, b1))
+  | (Pstr_type a0, Pstr_type b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_type_declaration (a1, b1)))
+        (a0, b0)
+  | (Pstr_exception (a0, a1), Pstr_exception (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_exception_declaration (a1, b1))
+  | (Pstr_exn_rebind (a0, a1), Pstr_exn_rebind (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (Asttypes.eq_loc Longident.eq_t (a1, b1))
+  | (Pstr_module (a0, a1), Pstr_module (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_expr (a1, b1))
+  | (Pstr_recmodule a0, Pstr_recmodule b0) ->
+      eq_list
+        (fun ((a0, a1, a2), (b0, b1, b2)) ->
+           ((Asttypes.eq_loc eq_string (a0, b0)) &&
+              (eq_module_type (a1, b1)))
+             && (eq_module_expr (a2, b2)))
+        (a0, b0)
+  | (Pstr_modtype (a0, a1), Pstr_modtype (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_type (a1, b1))
+  | (Pstr_open a0, Pstr_open b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pstr_class a0, Pstr_class b0) ->
+      eq_list eq_class_declaration (a0, b0)
+  | (Pstr_class_type a0, Pstr_class_type b0) ->
+      eq_list eq_class_type_declaration (a0, b0)
+  | (Pstr_include a0, Pstr_include b0) -> eq_module_expr (a0, b0)
+  | (_, _) -> false
+and eq_structure_item :
+  (structure_item * structure_item) -> 'result =
+  fun
+    ({ pstr_desc = a0; pstr_loc = a1 },
+     { pstr_desc = b0; pstr_loc = b1 })
+    -> (eq_structure_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_structure : (structure * structure) -> 'result =
+  fun (a0, a1) -> eq_list eq_structure_item (a0, a1)
+and eq_module_expr_desc :
+  (module_expr_desc * module_expr_desc) -> 'result =
+  function
+  | (Pmod_ident a0, Pmod_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pmod_structure a0, Pmod_structure b0) -> eq_structure (a0, b0)
+  | (Pmod_functor (a0, a1, a2), Pmod_functor (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_type (a1, b1)))
+        && (eq_module_expr (a2, b2))
+  | (Pmod_apply (a0, a1), Pmod_apply (b0, b1)) ->
+      (eq_module_expr (a0, b0)) && (eq_module_expr (a1, b1))
+  | (Pmod_constraint (a0, a1), Pmod_constraint (b0, b1)) ->
+      (eq_module_expr (a0, b0)) && (eq_module_type (a1, b1))
+  | (Pmod_unpack a0, Pmod_unpack b0) -> eq_expression (a0, b0)
+  | (_, _) -> false
+and eq_module_expr : (module_expr * module_expr) -> 'result =
+  fun
+    ({ pmod_desc = a0; pmod_loc = a1 },
+     { pmod_desc = b0; pmod_loc = b1 })
+    -> (eq_module_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_with_constraint :
+  (with_constraint * with_constraint) -> 'result =
+  function
+  | (Pwith_type a0, Pwith_type b0) -> eq_type_declaration (a0, b0)
+  | (Pwith_module a0, Pwith_module b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pwith_typesubst a0, Pwith_typesubst b0) ->
+      eq_type_declaration (a0, b0)
+  | (Pwith_modsubst a0, Pwith_modsubst b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (_, _) -> false
+and eq_modtype_declaration :
+  (modtype_declaration * modtype_declaration) -> 'result =
+  function
+  | (Pmodtype_abstract, Pmodtype_abstract) -> true
+  | (Pmodtype_manifest a0, Pmodtype_manifest b0) ->
+      eq_module_type (a0, b0)
+  | (_, _) -> false
+and eq_signature_item_desc :
+  (signature_item_desc * signature_item_desc) -> 'result =
+  function
+  | (Psig_value (a0, a1), Psig_value (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_value_description (a1, b1))
+  | (Psig_type a0, Psig_type b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_type_declaration (a1, b1)))
+        (a0, b0)
+  | (Psig_exception (a0, a1), Psig_exception (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_exception_declaration (a1, b1))
+  | (Psig_module (a0, a1), Psig_module (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_module_type (a1, b1))
+  | (Psig_recmodule a0, Psig_recmodule b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_module_type (a1, b1)))
+        (a0, b0)
+  | (Psig_modtype (a0, a1), Psig_modtype (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_modtype_declaration (a1, b1))
+  | (Psig_open a0, Psig_open b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Psig_include a0, Psig_include b0) -> eq_module_type (a0, b0)
+  | (Psig_class a0, Psig_class b0) ->
+      eq_list eq_class_description (a0, b0)
+  | (Psig_class_type a0, Psig_class_type b0) ->
+      eq_list eq_class_type_declaration (a0, b0)
+  | (_, _) -> false
+and eq_signature_item :
+  (signature_item * signature_item) -> 'result =
+  fun
+    ({ psig_desc = a0; psig_loc = a1 },
+     { psig_desc = b0; psig_loc = b1 })
+    -> (eq_signature_item_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_signature : (signature * signature) -> 'result =
+  fun (a0, a1) -> eq_list eq_signature_item (a0, a1)
+and eq_module_type_desc :
+  (module_type_desc * module_type_desc) -> 'result =
+  function
+  | (Pmty_ident a0, Pmty_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pmty_signature a0, Pmty_signature b0) -> eq_signature (a0, b0)
+  | (Pmty_functor (a0, a1, a2), Pmty_functor (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_type (a1, b1)))
+        && (eq_module_type (a2, b2))
+  | (Pmty_with (a0, a1), Pmty_with (b0, b1)) ->
+      (eq_module_type (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+                (eq_with_constraint (a1, b1)))
+           (a1, b1))
+  | (Pmty_typeof a0, Pmty_typeof b0) -> eq_module_expr (a0, b0)
+  | (_, _) -> false
+and eq_module_type : (module_type * module_type) -> 'result =
+  fun
+    ({ pmty_desc = a0; pmty_loc = a1 },
+     { pmty_desc = b0; pmty_loc = b1 })
+    -> (eq_module_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_declaration :
+  (class_declaration * class_declaration) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_expr (a0, a1)
+and eq_class_field_desc :
+  (class_field_desc * class_field_desc) -> 'result =
+  function
+  | (Pcf_inher (a0, a1, a2), Pcf_inher (b0, b1, b2)) ->
+      ((Asttypes.eq_override_flag (a0, b0)) &&
+         (eq_class_expr (a1, b1)))
+        && (eq_option eq_string (a2, b2))
+  | (Pcf_valvirt a0, Pcf_valvirt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((Asttypes.eq_loc eq_string (a0, b0)) &&
+            (Asttypes.eq_mutable_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pcf_val a0, Pcf_val b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((Asttypes.eq_loc eq_string (a0, b0)) &&
+             (Asttypes.eq_mutable_flag (a1, b1)))
+            && (Asttypes.eq_override_flag (a2, b2)))
+           && (eq_expression (a3, b3)))
+        (a0, b0)
+  | (Pcf_virt a0, Pcf_virt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((Asttypes.eq_loc eq_string (a0, b0)) &&
+            (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pcf_meth a0, Pcf_meth b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((Asttypes.eq_loc eq_string (a0, b0)) &&
+             (Asttypes.eq_private_flag (a1, b1)))
+            && (Asttypes.eq_override_flag (a2, b2)))
+           && (eq_expression (a3, b3)))
+        (a0, b0)
+  | (Pcf_constr a0, Pcf_constr b0) ->
+      (fun ((a0, a1), (b0, b1)) ->
+         (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+        (a0, b0)
+  | (Pcf_init a0, Pcf_init b0) -> eq_expression (a0, b0)
+  | (_, _) -> false
+and eq_class_field : (class_field * class_field) -> 'result =
+  fun
+    ({ pcf_desc = a0; pcf_loc = a1 }, { pcf_desc = b0; pcf_loc = b1
+     })
+    -> (eq_class_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_structure :
+  (class_structure * class_structure) -> 'result =
+  fun
+    ({ pcstr_pat = a0; pcstr_fields = a1 },
+     { pcstr_pat = b0; pcstr_fields = b1 })
+    -> (eq_pattern (a0, b0)) && (eq_list eq_class_field (a1, b1))
+and eq_class_expr_desc :
+  (class_expr_desc * class_expr_desc) -> 'result =
+  function
+  | (Pcl_constr (a0, a1), Pcl_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Pcl_structure a0, Pcl_structure b0) ->
+      eq_class_structure (a0, b0)
+  | (Pcl_fun (a0, a1, a2, a3), Pcl_fun (b0, b1, b2, b3)) ->
+      (((Asttypes.eq_label (a0, b0)) &&
+          (eq_option eq_expression (a1, b1)))
+         && (eq_pattern (a2, b2)))
+        && (eq_class_expr (a3, b3))
+  | (Pcl_apply (a0, a1), Pcl_apply (b0, b1)) ->
+      (eq_class_expr (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_label (a0, b0)) &&
+                (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pcl_let (a0, a1, a2), Pcl_let (b0, b1, b2)) ->
+      ((Asttypes.eq_rec_flag (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+            (a1, b1)))
+        && (eq_class_expr (a2, b2))
+  | (Pcl_constraint (a0, a1), Pcl_constraint (b0, b1)) ->
+      (eq_class_expr (a0, b0)) && (eq_class_type (a1, b1))
+  | (_, _) -> false
+and eq_class_expr : (class_expr * class_expr) -> 'result =
+  fun
+    ({ pcl_desc = a0; pcl_loc = a1 }, { pcl_desc = b0; pcl_loc = b1
+     })
+    -> (eq_class_expr_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_type_declaration :
+  (class_type_declaration * class_type_declaration) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_description :
+  (class_description * class_description) -> 'result =
+  fun (a0, a1) -> eq_class_infos eq_class_type (a0, a1)
+and eq_class_type_field_desc :
+  (class_type_field_desc * class_type_field_desc) -> 'result =
+  function
+  | (Pctf_inher a0, Pctf_inher b0) -> eq_class_type (a0, b0)
+  | (Pctf_val a0, Pctf_val b0) ->
+      (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+         (((eq_string (a0, b0)) &&
+             (Asttypes.eq_mutable_flag (a1, b1)))
+            && (Asttypes.eq_virtual_flag (a2, b2)))
+           && (eq_core_type (a3, b3)))
+        (a0, b0)
+  | (Pctf_virt a0, Pctf_virt b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pctf_meth a0, Pctf_meth b0) ->
+      (fun ((a0, a1, a2), (b0, b1, b2)) ->
+         ((eq_string (a0, b0)) && (Asttypes.eq_private_flag (a1, b1)))
+           && (eq_core_type (a2, b2)))
+        (a0, b0)
+  | (Pctf_cstr a0, Pctf_cstr b0) ->
+      (fun ((a0, a1), (b0, b1)) ->
+         (eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+        (a0, b0)
+  | (_, _) -> false
+and eq_class_type_field :
+  (class_type_field * class_type_field) -> 'result =
+  fun
+    ({ pctf_desc = a0; pctf_loc = a1 },
+     { pctf_desc = b0; pctf_loc = b1 })
+    ->
+    (eq_class_type_field_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_class_signature :
+  (class_signature * class_signature) -> 'result =
+  fun
+    ({ pcsig_self = a0; pcsig_fields = a1; pcsig_loc = a2 },
+     { pcsig_self = b0; pcsig_fields = b1; pcsig_loc = b2 })
+    ->
+    ((eq_core_type (a0, b0)) &&
+       (eq_list eq_class_type_field (a1, b1)))
+      && (Location.eq_t (a2, b2))
+and eq_class_type_desc :
+  (class_type_desc * class_type_desc) -> 'result =
+  function
+  | (Pcty_constr (a0, a1), Pcty_constr (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_list eq_core_type (a1, b1))
+  | (Pcty_signature a0, Pcty_signature b0) ->
+      eq_class_signature (a0, b0)
+  | (Pcty_fun (a0, a1, a2), Pcty_fun (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) && (eq_core_type (a1, b1))) &&
+        (eq_class_type (a2, b2))
+  | (_, _) -> false
+and eq_class_type : (class_type * class_type) -> 'result =
+  fun
+    ({ pcty_desc = a0; pcty_loc = a1 },
+     { pcty_desc = b0; pcty_loc = b1 })
+    -> (eq_class_type_desc (a0, b0)) && (Location.eq_t (a1, b1))
+and eq_exception_declaration :
+  (exception_declaration * exception_declaration) -> 'result =
+  fun (a0, a1) -> eq_list eq_core_type (a0, a1)
+and eq_type_kind : (type_kind * type_kind) -> 'result =
+  function
+  | (Ptype_abstract, Ptype_abstract) -> true
+  | (Ptype_variant a0, Ptype_variant b0) ->
+      eq_list
+        (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+           (((Asttypes.eq_loc eq_string (a0, b0)) &&
+               (eq_list eq_core_type (a1, b1)))
+              && (eq_option eq_core_type (a2, b2)))
+             && (Location.eq_t (a3, b3)))
+        (a0, b0)
+  | (Ptype_record a0, Ptype_record b0) ->
+      eq_list
+        (fun ((a0, a1, a2, a3), (b0, b1, b2, b3)) ->
+           (((Asttypes.eq_loc eq_string (a0, b0)) &&
+               (Asttypes.eq_mutable_flag (a1, b1)))
+              && (eq_core_type (a2, b2)))
+             && (Location.eq_t (a3, b3)))
+        (a0, b0)
+  | (_, _) -> false
+and eq_type_declaration :
+  (type_declaration * type_declaration) -> 'result =
+  fun
+    ({
+       ptype_params = a0;
+       ptype_cstrs = a1;
+       ptype_kind = a2;
+       ptype_private = a3;
+       ptype_manifest = a4;
+       ptype_variance = a5;
+       ptype_loc = a6
+     },
+     {
+       ptype_params = b0;
+       ptype_cstrs = b1;
+       ptype_kind = b2;
+       ptype_private = b3;
+       ptype_manifest = b4;
+       ptype_variance = b5;
+       ptype_loc = b6
+     })
+    ->
+    ((((((eq_list (eq_option (Asttypes.eq_loc eq_string)) (a0, b0))
+           &&
+           (eq_list
+              (fun ((a0, a1, a2), (b0, b1, b2)) ->
+                 ((eq_core_type (a0, b0)) && (eq_core_type (a1, b1)))
+                   && (Location.eq_t (a2, b2)))
+              (a1, b1)))
+          && (eq_type_kind (a2, b2)))
+         && (Asttypes.eq_private_flag (a3, b3)))
+        && (eq_option eq_core_type (a4, b4)))
+       &&
+       (eq_list
+          (fun ((a0, a1), (b0, b1)) ->
+             (eq_bool (a0, b0)) && (eq_bool (a1, b1)))
+          (a5, b5)))
+      && (Location.eq_t (a6, b6))
+and eq_value_description :
+  (value_description * value_description) -> 'result =
+  fun
+    ({ pval_type = a0; pval_prim = a1; pval_loc = a2 },
+     { pval_type = b0; pval_prim = b1; pval_loc = b2 })
+    ->
+    ((eq_core_type (a0, b0)) && (eq_list eq_string (a1, b1))) &&
+      (Location.eq_t (a2, b2))
+and eq_expression_desc :
+  (expression_desc * expression_desc) -> 'result =
+  function
+  | (Pexp_ident a0, Pexp_ident b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pexp_constant a0, Pexp_constant b0) ->
+      Asttypes.eq_constant (a0, b0)
+  | (Pexp_let (a0, a1, a2), Pexp_let (b0, b1, b2)) ->
+      ((Asttypes.eq_rec_flag (a0, b0)) &&
+         (eq_list
+            (fun ((a0, a1), (b0, b1)) ->
+               (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+            (a1, b1)))
+        && (eq_expression (a2, b2))
+  | (Pexp_function (a0, a1, a2), Pexp_function (b0, b1, b2)) ->
+      ((Asttypes.eq_label (a0, b0)) &&
+         (eq_option eq_expression (a1, b1)))
+        &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a2, b2))
+  | (Pexp_apply (a0, a1), Pexp_apply (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (Asttypes.eq_label (a0, b0)) &&
+                (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_match (a0, a1), Pexp_match (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_try (a0, a1), Pexp_try (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (eq_list
+           (fun ((a0, a1), (b0, b1)) ->
+              (eq_pattern (a0, b0)) && (eq_expression (a1, b1)))
+           (a1, b1))
+  | (Pexp_tuple a0, Pexp_tuple b0) -> eq_list eq_expression (a0, b0)
+  | (Pexp_construct (a0, a1, a2), Pexp_construct (b0, b1, b2)) ->
+      ((Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+         (eq_option eq_expression (a1, b1)))
+        && (eq_bool (a2, b2))
+  | (Pexp_variant (a0, a1), Pexp_variant (b0, b1)) ->
+      (Asttypes.eq_label (a0, b0)) &&
+        (eq_option eq_expression (a1, b1))
+  | (Pexp_record (a0, a1), Pexp_record (b0, b1)) ->
+      (eq_list
+         (fun ((a0, a1), (b0, b1)) ->
+            (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+              (eq_expression (a1, b1)))
+         (a0, b0))
+        && (eq_option eq_expression (a1, b1))
+  | (Pexp_field (a0, a1), Pexp_field (b0, b1)) ->
+      (eq_expression (a0, b0)) &&
+        (Asttypes.eq_loc Longident.eq_t (a1, b1))
+  | (Pexp_setfield (a0, a1, a2), Pexp_setfield (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) &&
+         (Asttypes.eq_loc Longident.eq_t (a1, b1)))
+        && (eq_expression (a2, b2))
+  | (Pexp_array a0, Pexp_array b0) -> eq_list eq_expression (a0, b0)
+  | (Pexp_ifthenelse (a0, a1, a2), Pexp_ifthenelse (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) && (eq_expression (a1, b1))) &&
+        (eq_option eq_expression (a2, b2))
+  | (Pexp_sequence (a0, a1), Pexp_sequence (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_while (a0, a1), Pexp_while (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_for (a0, a1, a2, a3, a4), Pexp_for (b0, b1, b2, b3, b4)) ->
+      ((((Asttypes.eq_loc eq_string (a0, b0)) &&
+           (eq_expression (a1, b1)))
+          && (eq_expression (a2, b2)))
+         && (Asttypes.eq_direction_flag (a3, b3)))
+        && (eq_expression (a4, b4))
+  | (Pexp_constraint (a0, a1, a2), Pexp_constraint (b0, b1, b2)) ->
+      ((eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1)))
+        && (eq_option eq_core_type (a2, b2))
+  | (Pexp_when (a0, a1), Pexp_when (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_send (a0, a1), Pexp_send (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_string (a1, b1))
+  | (Pexp_new a0, Pexp_new b0) ->
+      Asttypes.eq_loc Longident.eq_t (a0, b0)
+  | (Pexp_setinstvar (a0, a1), Pexp_setinstvar (b0, b1)) ->
+      (Asttypes.eq_loc eq_string (a0, b0)) &&
+        (eq_expression (a1, b1))
+  | (Pexp_override a0, Pexp_override b0) ->
+      eq_list
+        (fun ((a0, a1), (b0, b1)) ->
+           (Asttypes.eq_loc eq_string (a0, b0)) &&
+             (eq_expression (a1, b1)))
+        (a0, b0)
+  | (Pexp_letmodule (a0, a1, a2), Pexp_letmodule (b0, b1, b2)) ->
+      ((Asttypes.eq_loc eq_string (a0, b0)) &&
+         (eq_module_expr (a1, b1)))
+        && (eq_expression (a2, b2))
+  | (Pexp_assert a0, Pexp_assert b0) -> eq_expression (a0, b0)
+  | (Pexp_assertfalse, Pexp_assertfalse) -> true
+  | (Pexp_lazy a0, Pexp_lazy b0) -> eq_expression (a0, b0)
+  | (Pexp_poly (a0, a1), Pexp_poly (b0, b1)) ->
+      (eq_expression (a0, b0)) && (eq_option eq_core_type (a1, b1))
+  | (Pexp_object a0, Pexp_object b0) -> eq_class_structure (a0, b0)
+  | (Pexp_newtype (a0, a1), Pexp_newtype (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_expression (a1, b1))
+  | (Pexp_pack a0, Pexp_pack b0) -> eq_module_expr (a0, b0)
+  | (Pexp_open (a0, a1), Pexp_open (b0, b1)) ->
+      (Asttypes.eq_loc Longident.eq_t (a0, b0)) &&
+        (eq_expression (a1, b1))
+  | (_, _) -> false
+and eq_expression : (expression * expression) -> 'result =
+  fun
+    ({ pexp_desc = a0; pexp_loc = a1 },
+     { pexp_desc = b0; pexp_loc = b1 })
+    -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1))
+  
+let rec eq_directive_argument :
+  (directive_argument * directive_argument) -> 'result =
+  function
+  | (Pdir_none, Pdir_none) -> true
+  | (Pdir_string a0, Pdir_string b0) -> eq_string (a0, b0)
+  | (Pdir_int a0, Pdir_int b0) -> eq_int (a0, b0)
+  | (Pdir_ident a0, Pdir_ident b0) -> Longident.eq_t (a0, b0)
+  | (Pdir_bool a0, Pdir_bool b0) -> eq_bool (a0, b0)
+  | (_, _) -> false
+and eq_toplevel_phrase :
+  (toplevel_phrase * toplevel_phrase) -> 'result =
+  function
+  | (Ptop_def a0, Ptop_def b0) -> eq_structure (a0, b0)
+  | (Ptop_dir (a0, a1), Ptop_dir (b0, b1)) ->
+      (eq_string (a0, b0)) && (eq_directive_argument (a1, b1))
+  | (_, _) -> false
diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index a9fe53b5..e7709602 100644
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer299.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The lexer definition *)
 
 {
diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index 8b75d87f..24bd807f 100644
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: lexer301.mll 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The lexer definition *)
 
 {
diff --git a/tools/make-opcodes b/tools/make-opcodes
index c8f573c6..7cc7c5aa 100644
--- a/tools/make-opcodes
+++ b/tools/make-opcodes
@@ -1,2 +1,14 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1995 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.                #
+#                                                                       #
+#########################################################################
+
 $1=="enum" {n=0; next; }
            {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
diff --git a/tools/make-package-macosx b/tools/make-package-macosx
index b3152af8..1fa08919 100755
--- a/tools/make-package-macosx
+++ b/tools/make-package-macosx
@@ -12,8 +12,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: make-package-macosx 12783 2012-07-26 12:37:40Z doligez $
-
 cd package-macosx
 rm -rf ocaml.pkg ocaml-rw.dmg
 
@@ -86,7 +84,7 @@ mkdir -p resources
 #                                         stop here -> |
 cat >resources/ReadMe.txt <.bak.";
     print_endline "Interface files do not need label syntax conversion.";
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index c52c4fbe..b4a24ac4 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlcp.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open Printf
 
 let compargs = ref ([] : string list)
@@ -51,6 +49,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _cclib s = option_with_arg "-cclib" s
   let _ccopt s = option_with_arg "-ccopt" s
   let _config = option "-config"
+  let _compat_32 = option "-compat-32"
   let _custom = option "-custom"
   let _dllib = option_with_arg "-dllib"
   let _dllpath = option_with_arg "-dllpath"
@@ -73,9 +72,11 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _output_obj = option "-output-obj"
   let _pack = option "-pack"
   let _pp s = incompatible "-pp"
+  let _ppx s = incompatible "-ppx"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
   let _runtime_variant s = option_with_arg "-runtime-variant" s
+  let _short_paths = option "-short-paths"
   let _strict_sequence = option "-strict-sequence"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
@@ -91,7 +92,9 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _warn_help = option "-warn-help"
   let _where = option "-where"
   let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
   let _dparsetree = option "-dparsetree"
+  let _dtypedtree = option "-dtypedtree"
   let _drawlambda = option "-drawlambda"
   let _dlambda = option "-dlambda"
   let _dinstr = option "-dinstr"
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 32751d43..2b0b9513 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -10,21 +10,19 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamldep.ml 12759 2012-07-23 13:39:21Z lefessan $ *)
-
-open Longident
+open Compenv
 open Parsetree
 
-
+let ppf = Format.err_formatter
 (* Print the dependencies *)
 
 type file_kind = ML | MLI;;
 
+let include_dirs = ref []
 let load_path = ref ([] : (string * string array) list)
 let ml_synonyms = ref [".ml"]
 let mli_synonyms = ref [".mli"]
 let native_only = ref false
-let force_slash = ref false
 let error_occurred = ref false
 let raw_dependencies = ref false
 let sort_files = ref false
@@ -44,11 +42,30 @@ let fix_slash s =
     r
   end
 
+(* Since we reinitialize load_path after reading OCAMLCOMP,
+  we must use a cache instead of calling Sys.readdir too often. *)
+module StringMap = Map.Make(String)
+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_load_path dir =
   try
     let dir = Misc.expand_directory Config.standard_library dir in
-    let contents = Sys.readdir dir in
-    load_path := !load_path @ [dir, contents]
+    let contents = readdir dir in
+    load_path := (dir, contents) :: !load_path
   with Sys_error msg ->
     Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
     error_occurred := true
@@ -133,7 +150,7 @@ let find_dependency target_kind modname (byt_deps, opt_deps) =
 let (depends_on, escaped_eol) = (":", " \\\n    ")
 
 let print_filename s =
-  let s = if !force_slash then fix_slash s else s in
+  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
@@ -185,62 +202,6 @@ let print_raw_dependencies source_file deps =
     deps;
   print_char '\n'
 
-(* Optionally preprocess a source file *)
-
-let preprocessor = ref None
-
-exception Preprocessing_error
-
-let preprocess sourcefile =
-  match !preprocessor with
-    None -> sourcefile
-  | Some pp ->
-      flush Pervasives.stdout;
-      let tmpfile = Filename.temp_file "ocamldep_pp" "" in
-      let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
-      if Sys.command comm <> 0 then begin
-        Misc.remove_file tmpfile;
-        raise Preprocessing_error
-      end;
-      tmpfile
-
-let remove_preprocessed inputfile =
-  match !preprocessor with
-    None -> ()
-  | Some _ -> Misc.remove_file inputfile
-
-(* Parse a file or get a dumped syntax tree in it *)
-
-let is_ast_file ic ast_magic =
-  try
-    let buffer = Misc.input_bytes ic (String.length ast_magic) in
-    if buffer = ast_magic then true
-    else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
-      failwith "OCaml and preprocessor have incompatible versions"
-    else false
-  with End_of_file -> false
-
-let parse_use_file ic =
-  if is_ast_file ic Config.ast_impl_magic_number then
-    let _source_file = input_value ic in
-    [Ptop_def (input_value ic : Parsetree.structure)]
-  else begin
-    seek_in ic 0;
-    let lb = Lexing.from_channel ic in
-    Location.init lb !Location.input_name;
-    Parse.use_file lb
-  end
-
-let parse_interface ic =
-  if is_ast_file ic Config.ast_intf_magic_number then
-    let _source_file = input_value ic in
-    (input_value ic : Parsetree.signature)
-  else begin
-    seek_in ic 0;
-    let lb = Lexing.from_channel ic in
-    Location.init lb !Location.input_name;
-    Parse.interface lb
-  end
 
 (* Process one file *)
 
@@ -255,32 +216,43 @@ let report_err source_file exn =
         Syntaxerr.report_error err
     | Sys_error msg ->
         Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
-    | Preprocessing_error ->
+    | Pparse.Error err ->
         Format.fprintf Format.err_formatter
-                       "@[Preprocessing error on file %s@]@."
-            source_file
+                       "@[Preprocessing error on file %s@]@.@[%a@]@."
+          source_file
+          Pparse.report_error err
     | x -> raise x
 
-let read_parse_and_extract parse_function extract_function source_file =
+let read_parse_and_extract parse_function extract_function magic source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
   try
-    let input_file = preprocess source_file in
-    let ic = open_in_bin input_file in
-    let cleanup () = close_in ic; remove_preprocessed input_file in
-    try
-      let ast = parse_function ic in
+    let input_file = Pparse.preprocess source_file in
+    begin try
+      let ast =
+        Pparse.file Format.err_formatter input_file parse_function magic in
       extract_function Depend.StringSet.empty ast;
-      cleanup ();
+      Pparse.remove_preprocessed input_file;
       !Depend.free_structure_names
     with x ->
-      cleanup (); raise x
+      Pparse.remove_preprocessed input_file;
+      raise x
+    end
   with x ->
     report_err source_file x;
     Depend.StringSet.empty
 
 let ml_file_dependencies source_file =
-  let extracted_deps = read_parse_and_extract
-    parse_use_file Depend.add_use_file 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
+                           Config.ast_impl_magic_number source_file
   in
   if !sort_files then
     files := (source_file, ML, !Depend.free_structure_names) :: !files
@@ -311,8 +283,10 @@ let ml_file_dependencies source_file =
     end
 
 let mli_file_dependencies source_file =
-  let extracted_deps = read_parse_and_extract
-    parse_interface Depend.add_signature source_file in
+  let extracted_deps =
+    read_parse_and_extract Parse.interface Depend.add_signature
+                           Config.ast_intf_magic_number source_file
+  in
   if !sort_files then
     files := (source_file, MLI, extracted_deps) :: !files
   else
@@ -327,6 +301,13 @@ let mli_file_dependencies source_file =
     end
 
 let file_dependencies_as kind source_file =
+  Compenv.readenv ppf Before_compile;
+  load_path := [];
+  List.iter add_to_load_path (
+      (!Compenv.last_include_dirs @
+       !include_dirs @
+       !Compenv.first_include_dirs
+      ));
   Location.input_name := source_file;
   try
     if Sys.file_exists source_file then begin
@@ -432,11 +413,14 @@ let print_version_num () =
 
 let _ =
   Clflags.classic := false;
-  add_to_load_path Filename.current_dir_name;
+  first_include_dirs := Filename.current_dir_name :: !first_include_dirs;
+  Compenv.readenv ppf Before_args;
   Arg.parse [
+     "-absname", Arg.Set Location.absname,
+        " Show absolute filenames in error messages";
      "-all", Arg.Set all_dependencies,
         " Generate dependencies on all files";
-     "-I", Arg.String add_to_load_path,
+     "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs),
         "  Add  to the list of include directories";
      "-impl", Arg.String (file_dependencies_as ML),
         "  Process  as a .ml file";
@@ -452,9 +436,11 @@ let _ =
         " Generate dependencies for native-code only (no .cmo files)";
      "-one-line", Arg.Set one_line,
         " Output one line per file, regardless of the length";
-     "-pp", Arg.String(fun s -> preprocessor := Some s),
+     "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
          "  Pipe sources through preprocessor ";
-     "-slash", Arg.Set force_slash,
+     "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx),
+         "  Pipe abstract syntax trees through preprocessor ";
+     "-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";
@@ -463,5 +449,6 @@ let _ =
      "-vnum", Arg.Unit print_version_num,
          " Print version number and exit";
     ] file_dependencies usage;
+  Compenv.readenv ppf Before_link;
   if !sort_files then sort_files_by_dependencies !files;
   exit (if !error_occurred then 2 else 0)
diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
index b6c236ea..9a47d1b5 100644
--- a/tools/ocamlmklib.mlp
+++ b/tools/ocamlmklib.mlp
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlmklib.mlp 12723 2012-07-17 18:25:54Z doligez $ *)
-
 open Printf
 open Myocamlbuild_config
 
@@ -22,7 +20,8 @@ let compiler_path name =
 
 let bytecode_objs = ref []  (* .cmo,.cma,.ml,.mli files to pass to ocamlc *)
 and native_objs = ref []    (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *)
-and c_objs = ref []         (* .o, .a, .obj, .lib, .dll files to pass to mksharedlib and ar *)
+and c_objs = ref []         (* .o, .a, .obj, .lib, .dll files to pass
+                               to mksharedlib and ar *)
 and caml_libs = ref []      (* -cclib to pass to ocamlc, ocamlopt *)
 and caml_opts = ref []      (* -ccopt to pass to ocamlc, ocamlopt *)
 and dynlink = ref supports_shared_libraries
@@ -144,7 +143,8 @@ let parse_arguments argv =
   if !output_c = "" then output_c := !output
 
 let usage = "\
-Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\
+Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\
+                             .dll files>\
 \nOptions are:\
 \n  -cclib    C library passed to ocamlc -a or ocamlopt -a only\
 \n  -ccopt    C option passed to ocamlc -a or ocamlopt -a only\
diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
index 57f904c1..06288d74 100644
--- a/tools/ocamlmktop.ml
+++ b/tools/ocamlmktop.ml
@@ -10,8 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlmktop.ml 12477 2012-05-24 16:17:19Z xleroy $ *)
-
 let _ =
   let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
-  exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo"))
+  exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
+                    ocamlbytecomp.cma ocamltoplevel.cma "
+                   ^ args ^ " topstart.cmo"))
diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
index bd48fb2c..6d7d68b4 100644
--- a/tools/ocamlmktop.tpl
+++ b/tools/ocamlmktop.tpl
@@ -11,6 +11,5 @@
 #                                                                       #
 #########################################################################
 
-# $Id: ocamlmktop.tpl 12477 2012-05-24 16:17:19Z xleroy $
-
-exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo
+exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
+                       ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 86400d9c..c7d510d6 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlcp.ml 11890 2011-12-20 10:35:43Z frisch $ *)
-
 open Printf
 
 let compargs = ref ([] : string list)
@@ -76,10 +74,12 @@ module Options = Main_args.Make_optcomp_options (struct
   let _p = option "-p"
   let _pack = option "-pack"
   let _pp s = incompatible "-pp"
+  let _ppx s = incompatible "-ppx"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
   let _runtime_variant s = option_with_arg "-runtime-variant" s
   let _S = option "-S"
+  let _short_paths = option "-short-paths"
   let _strict_sequence = option "-strict-sequence"
   let _shared = option "-shared"
   let _thread = option "-thread"
@@ -94,7 +94,9 @@ module Options = Main_args.Make_optcomp_options (struct
   let _where = option "-where"
 
   let _nopervasives = option "-nopervasives"
+  let _dsource = option "-dsource"
   let _dparsetree = option "-dparsetree"
+  let _dtypedtree = option "-dtypedtree"
   let _drawlambda = option "-drawlambda"
   let _dlambda = option "-dlambda"
   let _dclambda = option "-dclambda"
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 1665076f..72c99009 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -11,14 +11,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlprof.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open Printf
 
-open Clflags
-open Config
 open Location
-open Misc
 open Parsetree
 
 (* User programs must not use identifiers that start with these prefixes. *)
@@ -52,7 +47,7 @@ let copy_chars_unix nchars =
   done
 
 let copy_chars_win32 nchars =
-  for i = 1 to nchars do
+  for _i = 1 to nchars do
     let c = input_char !inchan in
     if c <> '\r' then output_char !outchan c
   done
@@ -286,7 +281,7 @@ and rw_exp iflag sexp =
       List.iter (rewrite_class_field iflag) cl.pcstr_fields
 
   | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
-  | Pexp_open (_, e) -> rewrite_exp iflag e
+  | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e
   | Pexp_pack (smod) -> rewrite_mod iflag smod
 
 and rewrite_ifbody iflag ghost sifbody =
diff --git a/tools/pprintast.ml b/tools/pprintast.ml
deleted file mode 100644
index 161f8654..00000000
--- a/tools/pprintast.ml
+++ /dev/null
@@ -1,2157 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*   en Automatique.  All rights reserved.  This file is distributed      *)
-(*   under the terms of the Q Public License version 1.0.                 *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Original Code from Ber-metaocaml, modified fo 3.12.0 and fixed *)
-
-(* Printing code expressions *)
-(* Authors:  Ed Pizzi, Fabrice Le Fessant *)
-
-open Asttypes
-open Format
-open Location
-open Lexing
-open Parsetree
-
-
-(* borrowed from printast.ml *)
-let fmt_position f l =
-  if l.pos_fname = "" && l.pos_lnum = 1
-  then fprintf f "%d" l.pos_cnum
-  else if l.pos_lnum = -1
-  then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
-  else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
-               (l.pos_cnum - l.pos_bol)
-;;
-
-let fmt_location f loc =
-  fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end;
-  if loc.loc_ghost then fprintf f " ghost";
-;;
-
-let line i f s (*...*) =
-  fprintf f "%s" (String.make (2*i) ' ');
-  fprintf f s (*...*)
-;;
-
-let label i ppf x = line i ppf "label=\"%s\"\n" x;;
-
-(* end borrowing *)
-
-
-let indent    = 1 ;; (* standard indentation increment *)
-let bar_on_first_case = true ;;
-
-(* These sets of symbols are taken from the manual. However, it's
-   unclear what the sets infix_symbols and prefix_symbols are for, as
-   operator_chars, which contains their union seems to be the only set
-   useful to determine whether an identifier is prefix or infix.
-   The set postfix_chars I added, which is the set of characters allowed
-   at the end of an identifier to allow for internal MetaOCaml variable
-   renaming. *)
-
-let prefix_symbols  = [ '!'; '?'; '~' ] ;;
-let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-';
-                       '*'; '/'; '$'; '%' ] ;;
-let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/';
-                       ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ] ;;
-let numeric_chars  = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ] ;;
-
-type fixity =
-  | Infix
-  | Prefix ;;
-
-let is_infix fx =
-  match fx with
-  | Infix  -> true
-  | Prefix -> false ;;
-
-let special_infix_strings =
-  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ] ;;
-
-
-(*
-let is_special_infix_string s =
-   List.exists (fun x -> (x = s)) special_infix_strings ;;
-*)
-
-let is_in_list e l = List.exists (fun x -> (x = e)) l
-
-
-(* determines if the string is an infix string.
-   checks backwards, first allowing a renaming postfix ("_102") which
-   may have resulted from Pexp -> Texp -> Pexp translation, then checking
-   if all the characters in the beginning of the string are valid infix
-   characters. *)
-let fixity_of_string s =
-  if ((is_in_list s special_infix_strings)
-      || (is_in_list (String.get s 0) infix_symbols)) then Infix else Prefix
-
-let fixity_of_longident li =
-  match li.txt with
-  | Longident.Lident name ->
-      fixity_of_string name
-(* This is wrong (and breaks RTT):
-  | Longident.Ldot (_, name)
-    when is_in_list name special_infix_strings -> Infix
-*)
-  | _ -> Prefix ;;
-
-let fixity_of_exp e =
-  match e.pexp_desc with
-  | Pexp_ident (li) ->
-      (fixity_of_longident li)
-(*
-  | Pexp_cspval (_,li) ->
-          if false (* default valu of !Clflags.prettycsp *)
-          then (fixity_of_longident li)
-          else Prefix
-*)
-      | _ -> Prefix ;;
-
-let rec fmt_longident_aux f x =
-  match x with
-  | Longident.Lident s -> fprintf f "%s" s;
-  | Longident.Ldot(y, s) when is_in_list s special_infix_strings ->
-      fprintf f "%a.( %s )@ " fmt_longident_aux y s
-(* This is wrong (and breaks RTT):
-      fprintf f "@ %s@ " s
-*)
-  | Longident.Ldot (y, s) ->
-      begin
-            match s.[0] with
-          'a'..'z' | 'A'..'Z' ->
-            fprintf f "%a.%s" fmt_longident_aux y s
-        | _ ->
-            fprintf f "%a.( %s )@ " fmt_longident_aux y s
-
-      end
-
-  | Longident.Lapply (y, z) ->
-      fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
-;;
-
-let fmt_longident ppf x = fprintf ppf "%a" fmt_longident_aux x.txt;;
-
-let fmt_char f c =
-  let i = int_of_char c in
-  if (i < 32) || (i >= 128) then
-    fprintf f "'\\%03d'" (Char.code c)
-  else
-  match c with
-    '\'' | '\\' ->
-      fprintf f "'\\%c'" c
-  | _ ->
-    fprintf f "'%c'" c;;
-
-let fmt_constant f x =
-  match x with
-  | Const_int (i) ->
-      if (i < 0) then fprintf f "(%d)" i
-      else fprintf f "%d" i;
-  | Const_char (c) -> fprintf f "%a" fmt_char c ;
-  | Const_string (s) ->
-      fprintf f "%S" s;
-  | Const_float (s) ->
-      if ((String.get s 0) = '-') then fprintf f "(%s)" s
-      else fprintf f "%s" s;
-      (* maybe parenthesize all floats for consistency? *)
-  | Const_int32 (i) ->
-      if i < 0l then fprintf f "(%ldl)" i
-      else fprintf f "%ldl" i;
-  | Const_int64 (i) ->
-      if i < 0L then fprintf f "(%LdL)" i
-      else fprintf f "%LdL" i;
-  | Const_nativeint (i) ->
-      if i < 0n then
-        fprintf f "(%ndn)" i
-      else fprintf f "%ndn" i;
-;;
-
-let fmt_mutable_flag ppf x =
-  match x with
-  | Immutable -> ();
-  | Mutable -> fprintf ppf "mutable ";
-;;
-
-let string ppf s =
-  fprintf ppf "%s" s ;;
-
-let text ppf s =
-  fprintf ppf "%s" s.txt ;;
-
-let constant_string ppf s =
-  fprintf ppf "\"%s\"" (String.escaped s) ;;
-
-let fmt_virtual_flag f x =
-  match x with
-  | Virtual -> fprintf f "virtual ";
-  | Concrete -> ();
-;;
-
-let list f ppf l =
-  let n = List.length l in
-  List.iteri (fun i fmt ->
-    f ppf fmt;
-    if i < n-1 then
-      Format.fprintf ppf "\n")
-    l;;
-
-(* List2 - applies f to each element in list l, placing break hints
-     and a separator string between the resulting outputs.          *)
-
-let rec list2 f ppf l ?(indent=0) ?(space=1) ?(breakfirst=false)
-              ?(breaklast=false) sep =
-  match l with
-    [] -> if (breaklast=true) then pp_print_break ppf space indent;
-  | (last::[]) ->
-        if (breakfirst=true) then pp_print_break ppf space indent;
-        f ppf last;
-        if (breaklast=true) then pp_print_break ppf space indent;
-  | (first::rest) ->
-        if (breakfirst=true) then pp_print_break ppf space indent;
-        f ppf first ;
-        fprintf ppf sep;
-        pp_print_break ppf space indent;
-        list2 f ppf rest ~indent:indent ~space:space
-              ~breakfirst:false ~breaklast:breaklast sep ;;
-
-let type_var_print ppf str =
-  fprintf ppf "'%s" str.txt ;;
-
-let type_var_option_print ppf str =
-  match str with
-      None -> () (* TODO check *)
-    | Some str ->
-      fprintf ppf "'%s" str.txt ;;
-
-let fmt_class_params ppf (l, loc) =
-  let length = (List.length l) in
-  if (length = 0) then ()
-  else if (length = 1) then
-    fprintf ppf "%s@ " (List.hd l)
-  else begin
-    fprintf ppf "(" ;
-    list2 string ppf l "," ;
-    fprintf ppf ")@ " ;
-  end ;;
-
-let fmt_class_params_def ppf (l, loc) =
-  let length = (List.length l) in
-  if (length = 0) then ()
-  else begin
-    fprintf ppf "[" ;
-    list2 type_var_print ppf l "," ;
-    fprintf ppf "]@ ";
-  end ;;
-
-let fmt_rec_flag f x =
-  match x with
-  | Nonrecursive -> ();
-  | Recursive | Default -> fprintf f " rec";
-    (* todo - what is "default" recursion??
-        this seemed safe, as it's better to falsely make a non-recursive
-        let recursive than the opposite. *)
-;;
-
-let fmt_direction_flag ppf x =
-  match x with
-  | Upto   -> fprintf ppf "to" ;
-  | Downto -> fprintf ppf "downto" ;
-;;
-
-let fmt_private_flag f x =
-  match x with
-  | Public -> () ; (* fprintf f "Public"; *)
-  | Private -> fprintf f "private ";
-;;
-
-let option f ppf x = (* DELETE *)
-  match x with
-  | None -> () ;
-  | Some x ->
-      line 0 ppf "Some\n";
-      f ppf x;
-;;
-
-let option_quiet_p f ppf x =
-  match x with
-  | None -> ();
-  | Some x ->
-      fprintf ppf "@ (" ;
-      f ppf x;
-      fprintf ppf ")";
-;;
-
-let option_quiet f ppf x =
-  match x with
-  | None -> ();
-  | Some x ->
-      fprintf ppf "@ " ;
-      f ppf x;
-;;
-
-let rec expression_is_terminal_list exp =
-  match exp with
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]")}, None, _)}
-     -> true ;
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::")},
-                   Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
-     -> (expression_is_terminal_list exp2)
-  | {pexp_desc = _}
-     -> false
-;;
-
-let rec core_type ppf x =
-  match x.ptyp_desc with
-  | Ptyp_any -> fprintf ppf "_";         (* done *)
-  | Ptyp_var (s) -> fprintf ppf "'%s" s; (* done *)
-  | Ptyp_arrow (l, ct1, ct2) ->          (* done *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      (match l with
-        | "" -> core_type ppf ct1;
-        | s when (String.get s 0 = '?')  ->
-            (match ct1.ptyp_desc with
-              | Ptyp_constr ({ txt = Longident.Lident ("option")}, l) ->
-                  fprintf ppf "%s :@ " s ;
-                  type_constr_list ppf l ;
-              | _ -> core_type ppf ct1; (* todo: what do we do here? *)
-            );
-        | s ->
-            fprintf ppf "%s :@ " s ;
-            core_type ppf ct1; (* todo: what do we do here? *)
-      );
-      fprintf ppf "@ ->@ " ;
-      core_type ppf ct2 ;
-      fprintf ppf ")" ;
-      pp_close_box ppf () ;
-  | Ptyp_tuple l ->                      (* done *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      list2 core_type ppf l " *" ;
-      fprintf ppf ")" ;
-      pp_close_box ppf () ;
-  | Ptyp_constr (li, l) ->               (* done *)
-      pp_open_hovbox ppf indent ;
-      type_constr_list ppf ~space:true l ;
-      fprintf ppf "%a" fmt_longident li ;
-      pp_close_box ppf () ;
-  | Ptyp_variant (l, closed, low) ->
-      pp_open_hovbox ppf indent ;
-      (match closed with
-        | true  -> fprintf ppf "[ " ;
-        | false -> fprintf ppf "[> " ;
-      );
-      list2 type_variant_helper ppf l " |" ;
-      fprintf ppf " ]";
-      pp_close_box ppf () ;
-  | Ptyp_object (l) ->
-      if ((List.length l) > 0) then begin
-          pp_open_hovbox ppf indent ;
-          fprintf ppf "< " ;
-          list2 core_field_type ppf l " ;" ;
-          fprintf ppf " >" ;
-          pp_close_box ppf () ;
-        end else fprintf ppf "< >" ;
-(* line i ppf "Ptyp_object\n";
-         list i core_field_type ppf l; *)
-  | Ptyp_class (li, l, low) ->           (* done... sort of *)
-      pp_open_hovbox ppf indent ;
-      list2 core_type ppf l ~breaklast:true "" ;
-      fprintf ppf "#%a" fmt_longident li;
-      if ((List.length low) < 0) then begin (* done, untested *)
-          fprintf ppf "@ [> " ;
-          list2 class_var ppf low "" ;
-          fprintf ppf " ]";
-        end ;
-      pp_close_box ppf ();
-(* line i ppf "Ptyp_class %a\n" fmt_longident li;
-         list i core_type ppf l;
-         list i string ppf low *)
-  | Ptyp_alias (ct, s) ->                (* done *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      core_type ppf ct ;
-      fprintf ppf "@ as@ '%s)" s;
-      pp_close_box ppf () ;
-  | Ptyp_poly (sl, ct) ->                (* done? *)
-      pp_open_hovbox ppf indent ;
-      if ((List.length sl) > 0) then begin
-          list2 (fun ppf x -> fprintf ppf "'%s" x) ppf sl ~breaklast:true "";
-          fprintf ppf ".@ " ;
-        end ;
-      core_type ppf ct ;
-      pp_close_box ppf () ;
-  | Ptyp_package (lid, cstrs) ->
-      fprintf ppf "(module %a@ " fmt_longident lid;
-      pp_open_hovbox ppf indent;
-      begin match cstrs with
-          [] -> ()
-        | _ ->
-            fprintf ppf "@ with@ ";
-            string_x_core_type_ands ppf cstrs ;
-      end;
-      pp_close_box ppf ();
-      fprintf ppf ")";
-
-and class_var ppf s =
-  fprintf ppf "`%s" s ;
-
-and core_field_type ppf x =
-  match x.pfield_desc with
-  | Pfield (s, ct) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "%s :@ " s;
-      core_type ppf ct;
-      pp_close_box ppf () ;
-  | Pfield_var ->
-      fprintf ppf "..";
-
-and type_constr_list ppf ?(space=false) l =
-  match (List.length l) with
-  | 0 -> ()
-  | 1 -> list2 core_type ppf l "" ;
-      if (space) then fprintf ppf " " ;
-  | _ -> fprintf ppf "(" ;
-      list2 core_type ppf l "," ;
-      fprintf ppf ")" ;
-      if (space) then fprintf ppf " " ;
-
-and pattern_with_label ppf x s =
-  if (s = "") then simple_pattern ppf x
-  else begin
-      let s =
-        if (String.get s 0 = '?') then begin
-            fprintf ppf "?" ;
-            String.sub s 1 ((String.length s) - 1)
-          end else begin
-            fprintf ppf "~" ;
-            s
-          end in
-      fprintf ppf "%s" s ;
-      match x.ppat_desc with
-      | Ppat_var (s2) ->
-          if (s <> s2.txt) then begin
-              fprintf ppf ":" ;
-              simple_pattern ppf x ;
-            end
-      | _ -> fprintf ppf ":" ;
-          simple_pattern ppf x
-    end ;
-
-and pattern_with_when ppf whenclause x =
-  match whenclause with
-  | None -> pattern ppf x ;
-  | Some (e) ->
-      pp_open_hovbox ppf indent ;
-      pattern ppf x ;
-      fprintf ppf "@ when@ " ;
-      expression ppf e ;
-      pp_close_box ppf () ;
-
-and pattern ppf x =
-  match x.ppat_desc with
-    | Ppat_construct (li, po, b) ->
-      pp_open_hovbox ppf indent ;
-      (match li.txt,po with
-        | Longident.Lident("::"),
-          Some ({ppat_desc = Ppat_tuple([pat1; pat2])}) ->
-            fprintf ppf "(" ;
-            pattern ppf pat1 ;
-            fprintf ppf "@ ::@ " ;
-            pattern_list_helper ppf pat2 ;
-            fprintf ppf ")";
-        | _,_ ->
-            fprintf ppf "%a" fmt_longident li;
-            option_quiet pattern_in_parens ppf po;);
-      pp_close_box ppf () ;
-(* OXX what is this boolean ??
-         bool i ppf b;               *)
-
-  | _ ->
-      simple_pattern ppf x
-
-and simple_pattern ppf x =
-  match x.ppat_desc with
-  | Ppat_construct (li, None, _) ->
-      fprintf ppf "%a@ " fmt_longident li
-  | Ppat_any -> fprintf ppf "_";            (* OXX done *)
-  | Ppat_var ({txt = txt}) ->
-      if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then
-        fprintf ppf "(%s)" txt                (* OXX done *)
-      else
-        fprintf ppf "%s" txt;
-  | Ppat_alias (p, s) ->                    (* OXX done ... *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      pattern ppf p ;
-      fprintf ppf " as@ %s)" s.txt;
-      pp_close_box ppf () ;
-  | Ppat_constant (c) ->                    (* OXX done *)
-      fprintf ppf "%a" fmt_constant c;
-  | Ppat_tuple (l) ->                       (* OXX done *)
-      fprintf ppf "@[(";
-      list2 pattern ppf l ",";
-      fprintf ppf "@])";
-  | Ppat_variant (l, po) ->
-      (match po with
-        | None ->
-            fprintf ppf "`%s" l;
-        | Some (p) ->
-            pp_open_hovbox ppf indent ;
-            fprintf ppf "(`%s@ " l ;
-            pattern ppf p ;
-            fprintf ppf ")" ;
-            pp_close_box ppf () ;
-      );
-  | Ppat_record (l, closed) ->                     (* OXX done *)
-      fprintf ppf "{" ;
-      list2 longident_x_pattern ppf l ";" ;
-      begin match closed with
-          Open -> fprintf ppf "_ ";
-        | Closed -> ()
-      end;
-      fprintf ppf "}" ;
-  | Ppat_array (l) ->                      (* OXX done *)
-      pp_open_hovbox ppf 2 ;
-      fprintf ppf "[|" ;
-      list2 pattern ppf l ";" ;
-      fprintf ppf "|]" ;
-      pp_close_box ppf () ;
-  | Ppat_or (p1, p2) ->                    (* OXX done *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      pattern ppf p1 ;
-      fprintf ppf "@ | " ;
-      pattern ppf p2 ;
-      fprintf ppf ")" ;
-      pp_close_box ppf () ;
-  | Ppat_constraint (p, ct) ->             (* OXX done, untested *)
-      fprintf ppf "(" ;
-      pattern ppf p ;
-      fprintf ppf " :" ;
-      pp_print_break ppf 1 indent ;
-      core_type ppf ct ;
-      fprintf ppf ")" ;
-  | Ppat_type (li) ->                        (* OXX done *)
-      fprintf ppf "#%a" fmt_longident li ;
-  | Ppat_lazy p ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(lazy @ ";
-      pattern ppf p ;
-      fprintf ppf ")" ;
-      pp_close_box ppf ()
-  | Ppat_unpack (s) ->
-      fprintf ppf "(module@ %s)@ " s.txt
-  | _ ->
-      fprintf ppf "@[(";
-      pattern ppf x;
-      fprintf ppf "@])";
-
-and simple_expr ppf x =
-  match x.pexp_desc with
-  | Pexp_construct (li, None, _) ->
-      fprintf ppf "%a@ " fmt_longident li
-  | Pexp_ident (li) -> (* was (li, b) *)
-      if is_infix (fixity_of_longident li)
-        || match li.txt with
-          | Longident.Lident (li) -> List.mem li.[0] prefix_symbols
-          | _ -> false
-      then
-        fprintf ppf "(%a)" fmt_longident li
-      else
-        fprintf ppf "%a" fmt_longident li ;
-  | Pexp_constant (c) -> fprintf ppf "%a" fmt_constant c;
-  | Pexp_pack (me) ->
-      fprintf ppf "(module@ ";
-      pp_open_hovbox ppf indent;
-      module_expr ppf me;
-      pp_close_box ppf ();
-      fprintf ppf ")";
-  | Pexp_newtype (lid, e) ->
-      fprintf ppf "fun (type %s)@ " lid;
-      expression ppf e
-  | Pexp_tuple (l) ->
-      fprintf ppf "@[(";
-      list2 simple_expr ppf l ",";
-      fprintf ppf ")@]";
-  | Pexp_variant (l, eo) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "`%s" l ;
-      option_quiet expression ppf eo ;
-      pp_close_box ppf () ;
-  | Pexp_record (l, eo) ->
-      pp_open_hovbox ppf indent ; (* maybe just 1? *)
-      fprintf ppf "{" ;
-      begin
-        match eo with
-          None -> ()
-        | Some e ->
-            expression ppf e;
-            fprintf ppf "@ with@ "
-      end;
-      list2 longident_x_expression ppf l ";" ;
-      fprintf ppf "}" ;
-      pp_close_box ppf () ;
-  | Pexp_array (l) ->
-      pp_open_hovbox ppf 2 ;
-      fprintf ppf "[|" ;
-      list2 simple_expr ppf l ";" ;
-      fprintf ppf "|]" ;
-      pp_close_box ppf () ;
-  | Pexp_while (e1, e2) ->
-      pp_open_hvbox  ppf 0 ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "while@ " ;
-      expression ppf e1 ;
-      fprintf ppf " do" ;
-      pp_close_box ppf () ;
-      pp_print_break ppf 1 indent ;
-      expression_sequence ppf e2 ~first:false;
-      pp_print_break ppf 1 0 ;
-      fprintf ppf "done" ;
-      pp_close_box ppf () ;
-  | Pexp_for (s, e1, e2, df, e3) ->
-      pp_open_hvbox  ppf 0 ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "for %s =@ " s.txt ;
-      expression ppf e1 ;
-      fprintf ppf "@ %a@ " fmt_direction_flag df ;
-      expression ppf e2 ;
-      fprintf ppf " do" ;
-      pp_close_box ppf () ;
-
-      pp_print_break ppf 1 indent ;
-      expression_sequence ppf ~first:false e3 ;
-      pp_print_break ppf 1 0 ;
-      fprintf ppf "done" ;
-      pp_close_box ppf () ;
-
-
-  | _ ->
-      fprintf ppf "(@ ";
-      expression ppf x;
-      fprintf ppf "@ )"
-
-and expression ppf x =
-  match x.pexp_desc with
-  | Pexp_let (rf, l, e) ->
-      let l1 = (List.hd l) in
-      let l2 = (List.tl l) in
-      pp_open_hvbox ppf 0 ;
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "let%a " fmt_rec_flag rf;
-      pattern_x_expression_def ppf l1;
-      pattern_x_expression_def_list ppf l2;
-      pp_close_box ppf () ;
-      fprintf ppf " in" ;
-      pp_print_space ppf () ;
-      expression_sequence ppf ~first:false ~indent:0 e ;
-      pp_close_box ppf () ;
-  | Pexp_function (label, None, [
-        { ppat_desc = Ppat_var { txt ="*opt*" } },
-        { pexp_desc = Pexp_let (_, [
-              arg ,
-              { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e) }
-      ]
-    ) ->
-      expression ppf { x with pexp_desc = Pexp_function(label, Some eo,
-          [arg, e]) }
-
-  | Pexp_function (p, eo, l) ->
-      if (List.length l = 1) then begin
-          pp_open_hvbox ppf indent;
-          fprintf ppf "fun " ;
-          pattern_x_expression_case_single ppf (List.hd l) eo p
-        end else begin
-          pp_open_hvbox ppf 0;
-          fprintf ppf "function" ;
-          option_quiet expression_in_parens ppf eo ;
-          pp_print_space ppf () ;
-          pattern_x_expression_case_list ppf l ;
-        end ;
-      pp_close_box ppf ();
-  | Pexp_apply (e, l) -> (* was (e, l, _) *)
-      let fixity = (is_infix (fixity_of_exp e)) in
-      let sd =
-        (match e.pexp_desc with
-          | Pexp_ident ({ txt = Longident.Ldot (Longident.Lident(modname), valname) })
-            -> (modname, valname)
-          | Pexp_ident ({ txt = Longident.Lident(valname) })
-            -> ("",valname)
-          | _ -> ("",""))
-      in
-      (match sd,l with
-        | ("Array", "get"), [(_,exp1) ; (_,exp2)] ->
-            pp_open_hovbox ppf indent;
-            (match exp1.pexp_desc with
-              | Pexp_ident (_) ->
-                  expression ppf exp1 ;
-              | _ ->
-                  expression_in_parens ppf exp1 ;
-            );
-            fprintf ppf ".";
-            expression_in_parens ppf exp2;
-            pp_close_box ppf ();
-        | ("Array", "set"), [(_,array) ; (_,index) ; (_, valu)] ->
-            pp_open_hovbox ppf indent;
-            (match array.pexp_desc with
-              | Pexp_ident (_) ->
-                  expression ppf array ;
-              | _ ->
-                  expression_in_parens ppf array ;
-            );
-            fprintf ppf ".";
-            expression_in_parens ppf index;
-            fprintf ppf "@ <-@ ";
-            expression ppf valu;
-            pp_close_box ppf ();
-        | ("","!"),[(_,exp1)] ->
-            fprintf ppf "!" ;
-            simple_expr ppf exp1 ;
-(* | ("","raise"),[(_,exp)] ->
-               fprintf ppf "raising [" ;
-               expression ppf exp;
-               fprintf ppf "], says %s" st; *)
-        | (_,_) ->
-            pp_open_hovbox ppf (indent + 1) ;
-            fprintf ppf "(" ;
-            if (fixity = false) then
-              begin
-                (match e.pexp_desc with
-                  | Pexp_ident(_) -> expression ppf e ;
-                  | Pexp_send (_,_) -> expression ppf e ;
-                  | _ -> pp_open_hovbox ppf indent;
-                      expression_in_parens ppf e ;
-                      pp_close_box ppf () );
-                fprintf ppf "@ " ;
-                list2 label_x_expression_param ppf l "";
-              end
-            else begin
-                match l with
-                  [ arg1; arg2 ] ->
-                    label_x_expression_param ppf arg1 ;
-                    pp_print_space ppf () ;
-                    (match e.pexp_desc with
-                      | Pexp_ident(li) ->
-(* override parenthesization of infix identifier *)
-                          fprintf ppf "%a" fmt_longident li ;
-                      | _ -> simple_expr ppf e) ;
-                    pp_print_space ppf () ;
-                    label_x_expression_param ppf arg2
-                | _ ->
-(* fprintf ppf "(" ; *)
-                    simple_expr ppf e ;
-(* fprintf ppf ")" ; *)
-                    list2 label_x_expression_param ppf l ~breakfirst:true ""
-              end ;
-            fprintf ppf ")" ;
-            pp_close_box ppf () ;)
-  | Pexp_match (e, l) ->
-      fprintf ppf "(" ;
-      pp_open_hvbox ppf 0;
-      pp_open_hovbox ppf 2;
-      fprintf ppf "match@ " ;
-      expression ppf e ;
-      fprintf ppf " with" ;
-      pp_close_box ppf () ;
-      pp_print_space ppf () ;
-      pattern_x_expression_case_list ppf l ;
-      pp_close_box ppf () ;
-      fprintf ppf ")" ;
-  | Pexp_try (e, l) ->
-      fprintf ppf "(";
-      pp_open_vbox ppf 0; (* <-- always break here, says style manual *)
-      pp_open_hvbox ppf 0;
-      fprintf ppf "try";
-      pp_print_break ppf 1 indent ;
-      expression_sequence ppf ~first:false e;
-      pp_print_break ppf 1 0;
-      fprintf ppf "with";
-      pp_close_box ppf ();
-      pp_print_cut ppf ();
-      pattern_x_expression_case_list ppf l ;
-      pp_close_box ppf ();
-      fprintf ppf ")";
-  | Pexp_construct (li, eo, b) ->
-      (match li.txt with
-        | Longident.Lident ("::") ->
-            (match eo with
-                Some ({pexp_desc = Pexp_tuple ([exp1 ; exp2])}) ->
-                  pp_open_hovbox ppf indent ;
-                  if (expression_is_terminal_list exp2) then begin
-                      fprintf ppf "[" ;
-                      simple_expr ppf exp1 ;
-                      expression_list_helper ppf exp2 ;
-                      fprintf ppf "]" ;
-                    end else begin
-                      pp_open_hovbox ppf indent ;
-                      fprintf ppf "(@ ";
-                      simple_expr ppf exp1 ;
-                      fprintf ppf " ) ::@ " ;
-                      expression_list_nonterminal ppf exp2 ;
-                      fprintf ppf "@ " ;
-                      pp_close_box ppf () ;
-                    end ;
-                  pp_close_box ppf () ;
-              | _ -> assert false
-            );
-        | Longident.Lident ("()") -> fprintf ppf "()" ;
-        | _ ->
-            fprintf ppf "(";
-            pp_open_hovbox ppf indent ;
-            fmt_longident ppf li;
-            option_quiet expression_in_parens ppf eo;
-            pp_close_box ppf () ;
-            fprintf ppf ")"
-      );
-  | Pexp_field (e, li) ->
-      pp_open_hovbox ppf indent ;
-      (match e.pexp_desc with
-        | Pexp_ident (_) ->
-            simple_expr ppf e ;
-        | _ ->
-            expression_in_parens ppf e ;
-      );
-      fprintf ppf ".%a" fmt_longident li ;
-      pp_close_box ppf () ;
-  | Pexp_setfield (e1, li, e2) ->
-      pp_open_hovbox ppf indent ;
-      (match e1.pexp_desc with
-        | Pexp_ident (_) ->
-            simple_expr ppf e1 ;
-        | _ ->
-            expression_in_parens ppf e1 ;
-      );
-      fprintf ppf ".%a" fmt_longident li;
-      fprintf ppf "@ <-@ ";
-      expression ppf e2;
-      pp_close_box ppf () ;
-  | Pexp_ifthenelse (e1, e2, eo) ->
-      fprintf ppf "@[" ;
-      expression_if_common ppf e1 e2 eo;
-      fprintf ppf "@]";
-
-  | Pexp_sequence (e1, e2) ->
-      fprintf ppf "@[begin" ;
-      pp_print_break ppf 1 indent ;
-(* "@;<1 2>" ; *)
-      expression_sequence ppf ~first:false x ;
-      fprintf ppf "@;<1 0>end@]" ;
-  | Pexp_constraint (e, cto1, cto2) ->
-      (match (cto1, cto2) with
-        | (None, None) -> expression ppf e ;
-        | (Some (x1), Some (x2)) ->
-            pp_open_hovbox ppf 2 ;
-            fprintf ppf "(" ;
-            expression ppf e ;
-            fprintf ppf " :@ " ;
-            core_type ppf x1 ;
-            fprintf ppf " :>@ " ;
-            core_type ppf x2 ;
-            fprintf ppf ")" ;
-            pp_close_box ppf () ;
-        | (Some (x), None) ->
-            pp_open_hovbox ppf 2 ;
-            fprintf ppf "(" ;
-            expression ppf e ;
-            fprintf ppf " :@ " ;
-            core_type ppf x ;
-            fprintf ppf ")" ;
-            pp_close_box ppf ()
-        | (None, Some (x)) ->
-            pp_open_hovbox ppf 2 ;
-            fprintf ppf "(" ;
-            expression ppf e ;
-            fprintf ppf " :>@ " ;
-            core_type ppf x ;
-            fprintf ppf ")" ;
-            pp_close_box ppf ()
-      )
-  | Pexp_when (e1, e2) ->
-      assert false ;
-(* This is a wierd setup. The ocaml phrase
-          "pattern when condition -> expression"
-          found in pattern matching contexts is encoded as:
-          "pattern -> when condition expression"
-         Thus, the when clause ("when condition"), which one might expect
-          to be part of the pattern, is encoded as part of the expression
-          following the pattern.
-         A "when clause" should never exist in a vaccum. It should always
-          occur in a pattern matching context and be printed as part of the
-          pattern (in pattern_x_expression_case_list).
-         Thus these Pexp_when expressions are printed elsewhere, and if
-          this code is executed, an error has occurred. *)
-  | Pexp_send (e, s) ->
-      pp_open_hovbox ppf indent;
-      (match e.pexp_desc with
-        | Pexp_ident(_) ->
-            expression ppf e;
-            fprintf ppf "#%s" s;
-        | _ ->
-            fprintf ppf "(" ;
-            expression_in_parens ppf e;
-            fprintf ppf "@,#%s" s;
-            fprintf ppf ")"
-      );
-      pp_close_box ppf (); (* bug fixed? *)
-  | Pexp_new (li) ->
-      pp_open_hovbox ppf indent;
-      fprintf ppf "new@ %a" fmt_longident li;
-      pp_close_box ppf ();
-  | Pexp_setinstvar (s, e) ->
-      pp_open_hovbox ppf indent;
-      fprintf ppf "%s <-@ " s.txt;
-      expression ppf e;
-      pp_close_box ppf ();
-  | Pexp_override (l) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "{< " ;
-      if ((List.length l) > 0) then begin
-          list2 string_x_expression ppf l ";";
-          fprintf ppf " " ;
-        end ;
-      fprintf ppf ">}" ;
-      pp_close_box ppf () ;
-  | Pexp_letmodule (s, me, e) ->
-      pp_open_hvbox ppf 0 ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "let module %s =@ " s.txt ;
-      module_expr ppf me ;
-      fprintf ppf " in" ;
-      pp_close_box ppf () ;
-      pp_print_space ppf () ;
-      expression_sequence ppf ~first:false ~indent:0 e ;
-      pp_close_box ppf () ;
-  | Pexp_assert (e) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "assert@ " ;
-      expression ppf e ;
-      pp_close_box ppf () ;
-  | Pexp_assertfalse ->
-      fprintf ppf "assert false" ;
-  | Pexp_lazy (e) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "lazy@ " ;
-      simple_expr ppf e ;
-      pp_close_box ppf () ;
-  | Pexp_poly (e, cto) ->
-(* should this even print by itself? *)
-      (match cto with
-        | None -> expression ppf e ;
-        | Some (ct) ->
-            pp_open_hovbox ppf indent ;
-            expression ppf e ;
-            fprintf ppf "@ (* poly:@ " ;
-            core_type ppf ct ;
-            fprintf ppf " *)" ;
-            pp_close_box ppf () );
-  | Pexp_object cs ->
-      pp_open_hovbox ppf indent ;
-      class_structure ppf cs ;
-      pp_close_box ppf () ;
-  | Pexp_open (lid, e) ->
-      pp_open_hvbox ppf 0 ;
-      fprintf ppf "let open@ %a in@ " fmt_longident lid;
-      expression_sequence ppf ~first:false ~indent:0 e ;
-      pp_close_box ppf () ;
-  | _ -> simple_expr ppf x
-
-
-and value_description ppf x =
-  pp_open_hovbox ppf indent ;
-  core_type ppf x.pval_type;
-  if ((List.length x.pval_prim) > 0) then begin
-      fprintf ppf " =@ " ;
-      list2 constant_string ppf x.pval_prim "";
-    end ;
-  pp_close_box ppf () ;
-
-and type_declaration ppf x =
-  pp_open_hovbox ppf indent ;
-  (match x.ptype_manifest with
-     | None -> ()
-     | Some(y) ->
-         core_type ppf y;
-         match x.ptype_kind with
-           | Ptype_variant _ | Ptype_record _ -> fprintf ppf " = "
-           | Ptype_abstract -> ());
-  (match x.ptype_kind with
-    | Ptype_variant (first::rest) ->
-        pp_open_hovbox ppf indent ;
-
-        pp_open_hvbox ppf 0 ;
-        type_variant_leaf ppf first true ;
-        type_variant_leaf_list ppf rest ;
-(* string_x_core_type_list ppf lst; *)
-        pp_close_box ppf () ;
-
-        pp_close_box ppf () ;
-    | Ptype_variant [] ->
-        assert false ;
-    | Ptype_abstract -> ()
-    | Ptype_record l ->
-
-        pp_open_hovbox ppf indent ;
-
-        fprintf ppf "{" ;
-        pp_print_break ppf 0 indent ;
-        pp_open_hvbox ppf 0;
-        list2 type_record_field ppf l ";" ;
-        pp_close_box ppf () ;
-        fprintf ppf "@," ;
-        pp_close_box ppf () ;
-        fprintf ppf "}" ;
-
-        pp_close_box ppf () ;
-  );
-  list2 typedef_constraint ppf x.ptype_cstrs ~breakfirst:true "" ;
-  pp_close_box ppf () ;
-
-and exception_declaration ppf x =
-  match x with
-  | [] -> ()
-  | first::rest ->
-      fprintf ppf "@ of@ ";
-      list2 core_type ppf x " *";
-
-and class_type ppf x =
-  match x.pcty_desc with
-  | Pcty_signature (cs) ->
-      class_signature ppf cs;
-  | Pcty_constr (li, l) ->
-      pp_open_hovbox ppf indent ;
-      (match l with
-        | [] -> ()
-        | _  -> fprintf ppf "[" ;
-            list2 core_type ppf l "," ;
-            fprintf ppf "]@ " );
-      fprintf ppf "%a" fmt_longident li ;
-      pp_close_box ppf () ;
-  | Pcty_fun (l, co, cl) ->
-      pp_open_hovbox ppf indent ;
-      core_type ppf co ;
-      fprintf ppf " ->@ " ;
-      (match l with
-        | "" -> () ;
-        | _  -> fprintf ppf "[%s] " l ); (* todo - what's l *)
-      class_type ppf cl ;
-      pp_close_box ppf () ;
-
-and class_signature ppf { pcsig_self = ct; pcsig_fields = l } =
-  pp_open_hvbox ppf 0;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "object";
-  (match ct.ptyp_desc with
-    | Ptyp_any -> ()
-    | _ -> fprintf ppf "@ (";
-        core_type ppf ct;
-        fprintf ppf ")" );
-  pp_close_box ppf () ;
-  list2 class_type_field ppf l ~indent:indent ~breakfirst:true "";
-  pp_print_break ppf 1 0;
-  fprintf ppf "end";
-
-and class_type_field ppf x =
-  match x.pctf_desc with
-  | Pctf_inher (ct) ->      (* todo: test this *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "inherit@ " ;
-      class_type ppf ct ;
-      pp_close_box ppf () ;
-  | Pctf_val (s, mf, vf, ct) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "val %s%s%s :@ "
-        (match mf with
-        | Mutable -> "mutable "
-        | _       -> "")
-      (match vf with
-        | Virtual -> "virtual "
-        | _       -> "")
-      s;
-      core_type ppf ct ;
-      pp_close_box ppf () ;
-  | Pctf_virt (s, pf, ct) ->    (* todo: test this *)
-      pp_open_hovbox ppf indent ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "method@ %avirtual@ %s" fmt_private_flag pf s ;
-      pp_close_box ppf () ;
-      fprintf ppf " :@ " ;
-      core_type ppf ct ;
-      pp_close_box ppf () ;
-  | Pctf_meth (s, pf, ct) ->
-      pp_open_hovbox ppf indent ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "method %a%s" fmt_private_flag pf s;
-      pp_close_box ppf () ;
-      fprintf ppf " :@ " ;
-      core_type ppf ct ;
-      pp_close_box ppf () ;
-  | Pctf_cstr (ct1, ct2) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "constraint@ " ;
-      core_type ppf ct1;
-      fprintf ppf " =@ " ;
-      core_type ppf ct2;
-      pp_close_box ppf () ;
-
-and class_description ppf x =
-  pp_open_hvbox ppf 0 ;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "class %a%a%s :" fmt_virtual_flag x.pci_virt
-    fmt_class_params_def x.pci_params x.pci_name.txt ;
-  pp_close_box ppf () ;
-  pp_print_break ppf 1 indent ;
-  class_type ppf x.pci_expr ;
-  pp_close_box ppf () ;
-
-and class_type_declaration ppf x =
-  class_type_declaration_ext ppf true x ;
-
-and class_type_declaration_ext ppf first x =
-  pp_open_hvbox ppf 0;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%s@ %a%a%s =" (if (first) then "class type" else "and")
-  fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params
-    x.pci_name.txt ;
-  pp_close_box ppf ();
-  pp_print_break ppf 1 indent ;
-  class_type ppf x.pci_expr;
-  pp_close_box ppf ();
-
-and class_type_declaration_list ppf ?(first=true) l =
-  if (first) then pp_open_hvbox ppf 0 ;
-  match l with
-  | [] -> if (first) then pp_close_box ppf () ;
-  | h :: [] ->
-      class_type_declaration_ext ppf first h ;
-      pp_close_box ppf () ;
-  | h :: t ->
-      class_type_declaration_ext ppf first h ;
-      pp_print_space ppf () ;
-      class_type_declaration_list ppf ~first:false t ;
-
-and class_expr ppf x =
-  match x.pcl_desc with
-  | Pcl_structure (cs) ->
-      class_structure ppf cs ;
-  | Pcl_fun (l, eo, p, e) ->
-      pp_open_hvbox ppf indent;
-      pp_open_hovbox ppf indent;
-      fprintf ppf "fun@ ";
-      pattern ppf p;
-      fprintf ppf " ->";
-      pp_close_box ppf ();
-      (match (eo, l) with
-        | (None, "") -> () ;
-        | (_,_) ->
-            pp_open_hovbox ppf indent;
-            fprintf ppf " (* eo: ";
-            option expression ppf eo;
-            fprintf ppf "@ label: ";
-            label 0 ppf l;
-            fprintf ppf " *)";
-            pp_close_box ppf ()
-      );
-      fprintf ppf "@ ";
-      class_expr ppf e;
-      pp_close_box ppf ();
-  | Pcl_let (rf, l, ce) ->
-      let l1 = (List.hd l) in
-      let l2 = (List.tl l) in
-      pp_open_hvbox ppf 0 ;
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "let%a " fmt_rec_flag rf;
-      pattern_x_expression_def ppf l1;
-      pattern_x_expression_def_list ppf l2;
-      pp_close_box ppf () ;
-      pp_close_box ppf () ;
-      fprintf ppf " in" ;
-      pp_print_space ppf () ;
-      class_expr ppf ce;
-  | Pcl_apply (ce, l) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(";
-      class_expr ppf ce;
-      list2 label_x_expression_param ppf l ~breakfirst:true "";
-      fprintf ppf ")";
-      pp_close_box ppf () ;
-  | Pcl_constr (li, l) ->
-      pp_open_hovbox ppf indent;
-      if ((List.length l) != 0) then begin
-          fprintf ppf "[" ;
-          list2 core_type ppf l "," ;
-          fprintf ppf "]@ " ;
-        end ;
-      fprintf ppf "%a" fmt_longident li;
-      pp_close_box ppf ();
-  | Pcl_constraint (ce, ct) ->
-      pp_open_hovbox ppf indent;
-      fprintf ppf "(";
-      class_expr ppf ce;
-      fprintf ppf "@ : ";
-      class_type ppf ct;
-      fprintf ppf ")";
-      pp_close_box ppf ();
-
-and class_structure ppf { pcstr_pat = p; pcstr_fields =  l } =
-  pp_open_hvbox ppf 0 ;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "object" ;
-  (match p.ppat_desc with
-    | Ppat_any -> ();
-    | _ -> fprintf ppf "@ " ;
-        pattern_in_parens ppf p );
-  pp_close_box ppf () ;
-  list2 class_field ppf l ~indent:indent ~breakfirst:true "";
-  fprintf ppf "@ end" ;
-  pp_close_box ppf () ;
-
-and override ovf = match ovf with
-    Override -> "!"
-  | Fresh -> ""
-
-and class_field ppf x =
-  match x.pcf_desc with
-  | Pcf_inher (ovf, ce, so) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "inherit%s@ " (override ovf);
-      class_expr ppf ce;
-      (match so with
-        | None -> ();
-        | Some (s) -> fprintf ppf "@ as %s" s );
-      pp_close_box ppf ();
-  | Pcf_val (s, mf, ovf, e) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "val%s %a%s =@ " (override ovf) fmt_mutable_flag mf s.txt ;
-      expression_sequence ppf ~indent:0 e ;
-      pp_close_box ppf () ;
-  | Pcf_virt (s, pf, ct) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "method virtual %a%s" fmt_private_flag pf s.txt ;
-      fprintf ppf " :@ " ;
-      core_type ppf ct;
-      pp_close_box ppf () ;
-  | Pcf_valvirt (s, mf, ct) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "val virtual %s%s"
-        (match mf with
-        | Mutable -> "mutable "
-        | _       -> "")
-      s.txt;
-      fprintf ppf " :@ " ;
-      core_type ppf ct;
-      pp_close_box ppf () ;
-  | Pcf_meth (s, pf, ovf, e) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "method%s %a%s" (override ovf) fmt_private_flag pf s.txt ;
-      (match e.pexp_desc with
-        | Pexp_poly (e, Some(ct)) ->
-            fprintf ppf " :@ " ;
-            core_type ppf ct ;
-            fprintf ppf " =@ " ;
-            expression ppf e ;
-        | _ ->
-            fprintf ppf " =@ " ;
-            expression ppf e;
-      ) ;
-(* special Pexp_poly handling? *)
-      pp_close_box ppf () ;
-  | Pcf_constr (ct1, ct2) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "constraint@ ";
-      core_type ppf ct1;
-      fprintf ppf " =@ " ;
-      core_type ppf ct2;
-      pp_close_box ppf ();
-(*  | Pcf_let (rf, l) ->
-(* at the time that this was written, Pcf_let was commented out
-         of the parser, rendering this untestable. In the interest of
-         completeness, the following code is designed to print what
-         the parser seems to expect *)
-(* todo: test this, eventually *)
-      let l1 = (List.hd l) in
-      let l2 = (List.tl l) in
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "let%a " fmt_rec_flag rf;
-      pattern_x_expression_def ppf l1;
-      pattern_x_expression_def_list ppf l2;
-      fprintf ppf " in" ;
-      pp_close_box ppf () ; *)
-  | Pcf_init (e) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "initializer@ " ;
-      expression_sequence ppf ~indent:0 e ;
-      pp_close_box ppf () ;
-
-and class_fun_helper ppf e =
-  match e.pcl_desc with
-  | Pcl_fun (l, eo, p, e) ->
-      pattern ppf p;
-      fprintf ppf "@ ";
-      (match (eo, l) with
-        | (None, "") -> () ;
-        | (_,_) ->
-            fprintf ppf "(* ";
-            option expression ppf eo;
-            label 0 ppf l;
-            fprintf ppf " *)@ "
-      );
-      class_fun_helper ppf e;
-  | _ ->
-      e;
-
-and class_declaration_list ppf ?(first=true) l =
-  match l with
-  | [] ->
-      if (first = false) then pp_close_box ppf ();
-  | cd::l ->
-      let s = (if first then begin pp_open_hvbox ppf 0 ; "class" end
-          else begin pp_print_space ppf () ; "and" end) in
-      class_declaration ppf ~str:s cd ;
-      class_declaration_list ppf ~first:false l ;
-
-and class_declaration ppf ?(str="class") x =
-  pp_open_hvbox ppf indent ;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%s %a%a%s@ " str fmt_virtual_flag x.pci_virt
-    fmt_class_params_def x.pci_params x.pci_name.txt ;
-  let ce =
-    (match x.pci_expr.pcl_desc with
-      | Pcl_fun (l, eo, p, e) ->
-          class_fun_helper ppf x.pci_expr;
-      | _ -> x.pci_expr) in
-  let ce =
-    (match ce.pcl_desc with
-      | Pcl_constraint (ce, ct) ->
-          fprintf ppf ":@ " ;
-          class_type ppf ct ;
-          fprintf ppf "@ " ;
-          ce
-      | _ -> ce ) in
-  fprintf ppf "=" ;
-  pp_close_box ppf () ;
-  fprintf ppf "@ " ;
-  class_expr ppf ce ;
-  pp_close_box ppf () ;
-
-and module_type ppf x =
-  match x.pmty_desc with
-  | Pmty_ident (li) ->
-      fprintf ppf "%a" fmt_longident li;
-  | Pmty_signature (s) ->
-      pp_open_hvbox ppf 0;
-      fprintf ppf "sig";
-      list2 signature_item ppf s ~breakfirst:true ~indent:indent "";
-      pp_print_break ppf 1 0;
-      fprintf ppf "end";
-      pp_close_box ppf ();
-  | Pmty_functor (s, mt1, mt2) ->
-      pp_open_hvbox ppf indent;
-      pp_open_hovbox ppf indent;
-      fprintf ppf "functor@ (%s : " s.txt ;
-      module_type ppf mt1;
-      fprintf ppf ") ->";
-      pp_close_box ppf ();
-      pp_print_space ppf ();
-      module_type ppf mt2;
-      pp_close_box ppf ();
-  | Pmty_with (mt, l) ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "(" ;
-      module_type ppf mt ;
-      fprintf ppf "@ with@ " ;
-      longident_x_with_constraint_list ppf l ;
-      fprintf ppf ")" ;
-      pp_close_box ppf () ;
-  | Pmty_typeof me ->
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "module type of " ;
-      module_expr ppf me ;
-      pp_close_box ppf ()
-
-and signature ppf x = list signature_item ppf x
-
-and signature_item ppf x =
-  begin
-    match x.psig_desc with
-    | Psig_type (l) ->
-        let first = (List.hd l) in
-        let rest  = (List.tl l) in
-        pp_open_hvbox ppf 0;
-        pp_open_hvbox ppf 0;
-        fprintf ppf "type " ;
-        string_x_type_declaration ppf first;
-        pp_close_box ppf ();
-        type_def_list_helper ppf rest;
-        pp_close_box ppf ();
-    | Psig_value (s, vd) ->
-      let intro = if vd.pval_prim = [] then "val" else "external" in
-        pp_open_hovbox ppf indent ;
-        if (is_infix (fixity_of_string s.txt))
-          || List.mem s.txt.[0] prefix_symbols then
-          fprintf ppf "%s ( %s ) :@ "
-            intro s.txt                (* OXX done *)
-        else
-        fprintf ppf "%s %s :@ " intro s.txt;
-        value_description ppf vd;
-        pp_close_box ppf () ;
-    | Psig_exception (s, ed) ->
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "exception %s" s.txt;
-        exception_declaration ppf ed;
-        pp_close_box ppf ();
-    | Psig_class (l) ->
-        pp_open_hvbox ppf 0 ;
-        list2 class_description ppf l "";
-        pp_close_box ppf () ;
-    | Psig_module (s, mt) ->  (* todo: check this *)
-        pp_open_hovbox ppf indent ;
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "module@ %s :" s.txt ;
-        pp_close_box ppf () ;
-        pp_print_space ppf () ;
-        module_type ppf mt;
-        pp_close_box ppf () ;
-    | Psig_open (li) ->
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "open@ %a" fmt_longident li ;
-        pp_close_box ppf () ;
-    | Psig_include (mt) ->  (* todo: check this *)
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "include@ " ;
-        module_type ppf mt;
-        pp_close_box ppf () ;
-    | Psig_modtype (s, md) -> (* todo: check this *)
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "module type %s" s.txt ;
-        (match md with
-          | Pmodtype_abstract -> ()
-          | Pmodtype_manifest (mt) ->
-              pp_print_space ppf () ;
-              fprintf ppf " = " ;
-              module_type ppf mt;
-        );
-        pp_close_box ppf () ;
-    | Psig_class_type (l) ->
-        class_type_declaration_list ppf l ;
-    | Psig_recmodule decls ->
-        pp_open_hvbox ppf 0 ;
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "module rec@ " ;
-        string_x_module_type_list ppf decls ; (* closes hov box *)
-        pp_close_box ppf () ;
-  end;
-  fprintf ppf "\n"
-
-and modtype_declaration ppf x =
-  match x with
-  | Pmodtype_abstract -> line 0 ppf "Pmodtype_abstract\n";
-  | Pmodtype_manifest (mt) ->
-      line 0 ppf "Pmodtype_manifest\n";
-      module_type ppf mt;
-
-and module_expr ppf x =
-  match x.pmod_desc with
-  | Pmod_structure (s) ->
-      pp_open_hvbox ppf 0;
-      fprintf ppf "struct";
-      list2 structure_item ppf s ~breakfirst:true ~indent:indent "";
-      pp_print_break ppf 1 0;
-      fprintf ppf "end";
-      pp_close_box ppf (); (* bug fixed? *)
-  | Pmod_constraint (me, mt) ->
-      fprintf ppf "(";
-      pp_open_hovbox ppf indent;
-      module_expr ppf me;
-      fprintf ppf " :@ ";  (* <-- incorrect indentation? *)
-      module_type ppf mt;
-      pp_close_box ppf ();
-      fprintf ppf ")";
-  | Pmod_ident (li) ->
-      fprintf ppf "%a" fmt_longident li;
-  | Pmod_functor (s, mt, me) ->
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "functor (%s : " s.txt;
-      module_type ppf mt;
-      fprintf ppf ") ->@ ";
-      module_expr ppf me;
-      pp_close_box ppf () ;
-  | Pmod_apply (me1, me2) ->
-      pp_open_hovbox ppf indent;
-      fprintf ppf "(" ;
-      module_expr ppf me1;
-      fprintf ppf ")" ;
-      pp_print_cut ppf ();
-      fprintf ppf "(" ;
-      module_expr ppf me2;
-      fprintf ppf ")" ;
-      pp_close_box ppf ();
-  | Pmod_unpack e ->
-      fprintf ppf "(val@ ";
-      pp_open_hovbox ppf indent;
-      expression ppf e;
-      pp_close_box ppf ();
-      fprintf ppf ")";
-
-and structure ppf x =
-  list structure_item ppf x;
-
-(*
-(* closes one box *)
-and string_x_modtype_x_module ppf (s, _, mt, me) =
-(*
-  (match me.pmod_desc with
-   | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
-        | Pmty_signature (_))} as mt)) ->
-       (* assert false ; *) (* 3.07 - should this ever happen here? *)
-       fprintf ppf "%s :@ " s ;
-       module_type ppf mt ;
-       fprintf ppf " =" ;
-       pp_close_box ppf () ;
-       pp_print_space ppf () ;
-       module_expr ppf me ;
-   | _ ->
-*)
-  fprintf ppf "%s :@ " s;
-  module_type ppf mt ;
-  fprintf ppf " =" ;
-  pp_close_box ppf () ;
-  pp_print_space ppf () ;
-  module_expr ppf me ;
-(*  ) ; *)
-*)
-
-(* closes one box *)
-and text_x_modtype_x_module ppf (s, mt, me) =
-(*
-  (match me.pmod_desc with
-   | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
-        | Pmty_signature (_))} as mt)) ->
-       (* assert false ; *) (* 3.07 - should this ever happen here? *)
-       fprintf ppf "%s :@ " s ;
-       module_type ppf mt ;
-       fprintf ppf " =" ;
-       pp_close_box ppf () ;
-       pp_print_space ppf () ;
-       module_expr ppf me ;
-   | _ ->
-*)
-  fprintf ppf "%s :@ " s.txt;
-  module_type ppf mt ;
-  fprintf ppf " =" ;
-  pp_close_box ppf () ;
-  pp_print_space ppf () ;
-  module_expr ppf me ;
-(*  ) ; *)
-
-(*
-(* net gain of one box (-1, +2) *)
-and string_x_modtype_x_module_list ppf l =
-  match l with
-  | [] -> ()
-  | hd :: tl ->
-      pp_close_box ppf () ;
-      pp_print_space ppf () ;
-      pp_open_hvbox ppf indent ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "and " ;
-      string_x_modtype_x_module ppf hd; (* closes a box *)
-      string_x_modtype_x_module_list ppf tl ; (* net open of one box *)
-*)
-
-(* net gain of one box (-1, +2) *)
-and text_x_modtype_x_module_list ppf l =
-  match l with
-  | [] -> ()
-  | hd :: tl ->
-      pp_close_box ppf () ;
-      pp_print_space ppf () ;
-      pp_open_hvbox ppf indent ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "and " ;
-      text_x_modtype_x_module ppf hd; (* closes a box *)
-      text_x_modtype_x_module_list ppf tl ; (* net open of one box *)
-
-(* context: [hv [hov .]]  returns [hv .]
-   closes inner hov box. *)
-and string_x_module_type_list ppf ?(first=true) l =
-  match l with
-  | [] -> () ;
-  | hd :: tl ->
-      if (first=false) then begin
-          pp_print_space ppf () ;
-          pp_open_hovbox ppf indent ;
-          fprintf ppf "and " ;
-        end ;
-      string_x_module_type ppf hd ;
-      pp_close_box ppf () ;
-      string_x_module_type_list ppf ~first:false tl ;
-
-and string_x_module_type ppf (s, mty) =
-  fprintf ppf "%s :@ " s.txt ;
-  module_type ppf mty ;
-
-and structure_item ppf x =
-  begin
-    match x.pstr_desc with
-    | Pstr_eval (e) ->
-        pp_open_hvbox ppf 0 ;
-        fprintf ppf "let _ = " ;
-        expression_sequence ppf ~first:false ~indent:0 e ;
-        pp_close_box ppf () ;
-    | Pstr_type [] -> assert false
-    | Pstr_type (first :: rest) ->
-        pp_open_vbox ppf 0;
-        pp_open_hvbox ppf 0;
-        fprintf ppf "type " ;
-        string_x_type_declaration ppf first;
-        pp_close_box ppf ();
-        type_def_list_helper ppf rest;
-        pp_close_box ppf ();
-    | Pstr_value (rf, l) ->
-        let l1 = (List.hd l) in
-        let l2 = (List.tl l) in
-        pp_open_hvbox ppf 0 ;
-        pp_open_hvbox ppf indent ;
-        fprintf ppf "let%a " fmt_rec_flag rf;
-        pattern_x_expression_def ppf l1;
-        pattern_x_expression_def_list ppf l2;
-        pp_close_box ppf () ;
-        pp_close_box ppf () ;
-    | Pstr_exception (s, ed) ->
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "exception@ %s" s.txt;
-        exception_declaration ppf ed;
-        pp_close_box ppf () ;
-    | Pstr_module (s, me) ->
-        pp_open_hvbox ppf indent;
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "module %s" s.txt ;
-        (match me.pmod_desc with
-          | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_)
-                  | Pmty_signature (_))} as mt)) ->
-              fprintf ppf " :@ " ;
-              module_type ppf mt ;
-              fprintf ppf " =" ;
-              pp_close_box ppf () ;
-              pp_print_space ppf () ;
-              module_expr ppf me ;
-          | _ ->
-              fprintf ppf " =" ;
-              pp_close_box ppf () ;
-              pp_print_space ppf () ;
-              module_expr ppf me ;
-        ) ;
-        pp_close_box ppf ();
-    | Pstr_open (li) ->
-        fprintf ppf "open %a" fmt_longident li;
-    | Pstr_modtype (s, mt) ->
-        pp_open_hovbox ppf indent;
-        fprintf ppf "module type %s =@ " s.txt;
-        module_type ppf mt;
-        pp_close_box ppf () ; (* bug fixed? *)
-    | Pstr_class (l) ->
-        class_declaration_list ppf l;
-    | Pstr_class_type (l) ->
-        class_type_declaration_list ppf l ;
-    | Pstr_primitive (s, vd) ->
-        pp_open_hovbox ppf indent ;
-        let need_parens =
-          match s.txt with
-          | "or"
-          | "mod"
-          | "land"
-          | "lor"
-          | "lxor"
-          | "lsl"
-          | "lsr"
-          | "asr"
-            -> true
-
-          | _ ->
-              match s.txt.[0] with
-                'a'..'z' -> false
-              | _ -> true
-        in
-        if need_parens then
-          fprintf ppf "external@ ( %s ) :@ " s.txt
-        else
-          fprintf ppf "external@ %s :@ " s.txt;
-        value_description ppf vd;
-        pp_close_box ppf () ;
-    | Pstr_include me ->
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "include " ;
-        module_expr ppf me ;
-        pp_close_box ppf () ;
-    | Pstr_exn_rebind (s, li) ->        (* todo: check this *)
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "exception@ %s =@ %a" s.txt fmt_longident li ;
-        pp_close_box ppf () ;
-    | Pstr_recmodule decls -> (* 3.07 *)
-        let l1 = (List.hd decls) in
-        let l2 = (List.tl decls) in
-        pp_open_hvbox ppf 0;        (* whole recmodule box *)
-        pp_open_hvbox ppf indent ;  (* this definition box *)
-        pp_open_hovbox ppf indent ; (* first line box *)
-        fprintf ppf "module rec " ;
-        text_x_modtype_x_module ppf l1; (* closes a box *)
-        text_x_modtype_x_module_list ppf l2; (* net opens one box *)
-        pp_close_box ppf () ;
-        pp_close_box ppf () ;
-        pp_close_box ppf () ;
-  end;
-  fprintf ppf "\n"
-
-and type_def_list_helper ppf l =
-  match l with
-  | [] -> ()
-  | first :: rest ->
-      pp_print_space ppf () ;
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "and " ;
-      string_x_type_declaration ppf first;
-      pp_close_box ppf () ;
-      type_def_list_helper ppf rest ;
-
-and string_x_type_declaration ppf (s, td) =
-  let l = td.ptype_params in
-  (match (List.length l) with
-    | 0 -> ()
-    | 1 -> list2 type_var_option_print ppf l "" ;
-        fprintf ppf " " ;
-    | _ -> pp_open_hovbox ppf indent ;
-        fprintf ppf "(" ;
-        list2 type_var_option_print ppf l "," ;
-        fprintf ppf ")" ;
-        pp_close_box ppf ();
-        fprintf ppf " " ;
-  );
-  fprintf ppf "%s" s.txt ;
-  (match (td.ptype_kind, td.ptype_manifest) with
-    | Ptype_abstract, None -> ()
-    | Ptype_record _, _ -> fprintf ppf " = " ;
-    | _ , _ -> fprintf ppf " =" ;
-        pp_print_break ppf 1 indent ;
-  );
-  type_declaration ppf td;
-
-and longident_x_with_constraint_list ?(first=true) ppf l =
-  match l with
-  | [] -> () ;
-  | h :: [] ->
-      if (first = false) then fprintf ppf "@ and " ;
-      longident_x_with_constraint ppf h ;
-  | h :: t  ->
-      if (first = false) then fprintf ppf "@ and " ;
-      longident_x_with_constraint ppf h ;
-      fprintf ppf "@ and " ;
-      longident_x_with_constraint ppf h ;
-      longident_x_with_constraint_list ~first:false ppf t;
-
-and string_x_core_type_ands ?(first=true) ppf l =
-  match l with
-  | [] -> () ;
-  | h :: [] ->
-      if (first = false) then fprintf ppf "@ and " ;
-      string_x_core_type ppf h ;
-  | h :: t  ->
-      if (first = false) then fprintf ppf "@ and " ;
-      string_x_core_type ppf h;
-      string_x_core_type_ands ~first:false ppf t;
-
-and string_x_core_type ppf (s, ct) =
-  fprintf ppf "%a@ =@ %a" fmt_longident s core_type ct
-
-and longident_x_with_constraint ppf (li, wc) =
-  match wc with
-  | Pwith_type (td) ->
-      fprintf ppf "type@ %a =@ " fmt_longident li;
-      type_declaration ppf td ;
-  | Pwith_module (li2) ->
-      fprintf ppf "module %a =@ %a" fmt_longident li fmt_longident li2;
-  | Pwith_typesubst td ->
-      fprintf ppf "type@ %a :=@ " fmt_longident li;
-      type_declaration ppf td ;
-  | Pwith_modsubst (li2) ->
-      fprintf ppf "module %a :=@ %a" fmt_longident li fmt_longident li2;
-
-and typedef_constraint ppf (ct1, ct2, l) =
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "constraint@ " ;
-  core_type ppf ct1;
-  fprintf ppf " =@ " ;
-  core_type ppf ct2;
-  pp_close_box ppf () ;
-
-and type_variant_leaf ppf (s, l,_, _) first = (* TODO *)
-  if (first) then begin
-      pp_print_if_newline ppf ();
-      pp_print_string ppf "  ";
-    end else begin
-      pp_print_space ppf ();
-      fprintf ppf "| " ;
-    end ;
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%s" s.txt ;
-  if ((List.length l) > 0) then begin
-      fprintf ppf "@ of@ " ;
-      list2 core_type ppf l " *"
-    end ;
-  pp_close_box ppf ();
-
-and type_variant_leaf_list ppf list =
-  match list with
-  | [] -> ()
-  | first :: rest ->
-      type_variant_leaf ppf first false ;
-      type_variant_leaf_list ppf rest ;
-
-and type_record_field ppf (s, mf, ct,_) =
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%a%s:" fmt_mutable_flag mf s.txt ;
-  core_type ppf ct ;
-  pp_close_box ppf () ;
-
-and longident_x_pattern ppf (li, p) =
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%a =@ " fmt_longident li;
-  pattern ppf p;
-  pp_close_box ppf () ;
-
-
-
-and pattern_x_expression_case_list
-    ppf ?(first:bool=true) ?(special_first_case=bar_on_first_case)
-  (l:(pattern * expression) list) =
-  match l with
-  | []        -> ()
-  | (p,e)::[] -> (* last time *)
-      if (first=false) then
-        fprintf ppf "| " ;
-      pp_open_hvbox ppf indent ;
-      let (e,w) =
-        (match e with
-          | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1))
-          | _ -> (e, None)) in
-      pattern_with_when ppf w p ;
-      fprintf ppf " ->@ " ;
-      pp_open_hvbox ppf 0 ;
-      expression_sequence ppf ~indent:0 e ;
-      pp_close_box ppf () ;
-      pp_close_box ppf () ;
-  | (p,e)::r  -> (* not last  *)
-      pp_open_hvbox ppf (indent + 2) ;
-      if ((first=true) & (special_first_case=false)) then begin
-          pp_print_if_newline ppf () ;
-          pp_print_string ppf "  "
-        end else
-        fprintf ppf "| " ;
-      let (e,w) =
-        (match e with
-          | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1))
-          | _ -> (e, None)) in
-      pattern_with_when ppf w p ;
-      fprintf ppf " ->@ " ;
-      pp_open_hvbox ppf 0 ;
-      expression_sequence ppf ~indent:0 e ;
-      pp_close_box ppf () ;
-      pp_close_box ppf () ;
-      pp_print_break ppf 1 0;
-      (pattern_x_expression_case_list ppf ~first:false r);
-
-and pattern_x_expression_def ppf (p, e) =
-  pattern ppf p ;
-  fprintf ppf " =@ " ;
-  expression ppf e;
-
-and pattern_list_helper ppf p =
-  match p with
-  | {ppat_desc = Ppat_construct ({ txt = Longident.Lident("::") },
-        Some ({ppat_desc = Ppat_tuple([pat1; pat2])}),
-        _)}
-    -> pattern ppf pat1 ;
-      fprintf ppf "@ ::@ " ;
-      pattern_list_helper ppf pat2 ;
-  | _ -> pattern ppf p ;
-
-and string_x_expression ppf (s, e) =
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%s =@ " s.txt ;
-  expression ppf e ;
-  pp_close_box ppf () ;
-
-and longident_x_expression ppf (li, e) =
-  pp_open_hovbox ppf indent ;
-  fprintf ppf "%a =@ " fmt_longident li;
-  simple_expr ppf e;
-  pp_close_box ppf () ;
-
-and label_x_expression_param ppf (l,e) =
-  match l with
-  | ""  -> simple_expr ppf e ;
-  | lbl ->
-      if ((String.get lbl 0) = '?') then begin
-          fprintf ppf "%s:" lbl ;
-          simple_expr ppf e ;
-        end else begin
-          fprintf ppf "~%s:" lbl ;
-          simple_expr ppf e ;
-        end ;
-
-and expression_in_parens ppf e =
-  let already_has_parens =
-    (match e.pexp_desc with
-        Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Ldot (
-                Longident.Lident(modname), funname) })},_)
-        -> (match modname,funname with
-            | "Array","get" -> false;
-            | "Array","set" -> false;
-            | _,_ -> true) ;
-      | Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Lident(funname) })},_)
-        -> (match funname with
-            | "!" -> false;
-            | _ -> true);
-      | Pexp_apply (_,_) -> true;
-      | Pexp_match (_,_) -> true;
-      | Pexp_tuple (_) -> true ;
-      | Pexp_constraint (_,_,_) -> true ;
-      | _ -> false) in
-  if (already_has_parens) then expression ppf e
-  else begin
-      fprintf ppf "(" ;
-      expression ppf e ;
-      fprintf ppf ")" ;
-    end ;
-
-and pattern_in_parens ppf p =
-  let already_has_parens =
-    match p.ppat_desc with
-    | Ppat_alias (_,_) -> true
-    | Ppat_tuple (_) -> true
-    | Ppat_or (_,_) -> true
-    | Ppat_constraint (_,_) -> true
-    | _ -> false in
-  if (already_has_parens) then pattern ppf p
-  else begin
-      fprintf ppf "(" ;
-      pattern ppf p ;
-      fprintf ppf ")" ;
-    end;
-
-and pattern_constr_params_option ppf po =
-  match po with
-  | None -> ();
-  | Some pat ->
-      pp_print_space ppf ();
-      pattern_in_parens ppf pat;
-
-and type_variant_helper ppf x =
-  match x with
-  | Rtag (l, b, ctl) ->  (* is b important? *)
-      pp_open_hovbox ppf indent ;
-      fprintf ppf "`%s" l ;
-      if ((List.length ctl) != 0) then begin
-          fprintf ppf " of@ " ;
-          list2 core_type ppf ctl " *" ;
-        end ;
-      pp_close_box ppf () ;
-  | Rinherit (ct) ->
-      core_type ppf ct
-
-(* prints a list of definitions as found in a let statement
-   note! breaks "open and close boxes in same function" convention, however
-         does always open and close the same number of boxes. (i.e. no "net
-         gain or loss" of box depth.                                         *)
-and pattern_x_expression_def_list ppf l =
-  match l with
-  | [] -> ()
-  | hd :: tl ->
-      pp_close_box ppf () ;
-      pp_print_space ppf () ;
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "and " ;
-      pattern_x_expression_def ppf hd;
-      pattern_x_expression_def_list ppf tl ;
-
-(* end an if statement by printing an else phrase if there is an "else"
-   statement in the ast. otherwise just close the box. *)
-(* added: special case for "else if" case *)
-
-and expression_eo ppf eo extra =
-  match eo with
-  | None   -> ();
-  | Some x ->
-      if extra then fprintf ppf " "
-      else fprintf ppf "@ " ;
-      match x.pexp_desc with
-      | Pexp_ifthenelse (e1, e2, eo) ->   (* ... else if ...*)
-          fprintf ppf "else" ;
-          expression_elseif ppf (e1, e2, eo)
-      | Pexp_sequence (e1, e2) ->
-          fprintf ppf "else" ;
-          expression_ifbegin ppf x;       (* ... else begin ... end*)
-      | _ ->                              (* ... else ... *)
-          pp_open_hvbox ppf indent ;
-          fprintf ppf "else@ " ;
-          expression ppf x ;
-          pp_close_box ppf () ;
-
-and expression_elseif ppf (e1,e2,eo) =
-  fprintf ppf " " ;
-  expression_if_common ppf e1 e2 eo ;
-
-and expression_ifbegin ppf e =
-  fprintf ppf " begin";
-  pp_print_break ppf 1 indent ; (* "@;<1 2>"; *)
-  expression_sequence ppf e;
-  pp_print_break ppf 1 0 ; (* fprintf ppf "@;<1 0>" *)
-  fprintf ppf "end";
-
-and expression_if_common ppf e1 e2 eo =
-  match eo, e2.pexp_desc with
-  | None, Pexp_sequence (_, _) ->
-      fprintf ppf "if@ " ;
-      expression ppf e1;
-      fprintf ppf "@ then@ " ;
-      expression_ifbegin ppf e2
-  | None, _ ->
-      fprintf ppf "if@ " ;
-      expression ppf e1;
-      fprintf ppf "@ then@ " ;
-      simple_expr ppf e2
-  | Some _, Pexp_sequence _ ->
-      fprintf ppf "if " ;
-      expression ppf e1;
-      fprintf ppf "@ then@ " ;
-      expression_ifbegin ppf e2;
-      expression_eo ppf eo true;   (* ... then begin ... end *)
-  | Some _, _ ->
-      pp_open_hvbox ppf indent ;
-      fprintf ppf "if " ;
-      expression ppf e1;
-      fprintf ppf " then@ " ;
-      simple_expr ppf e2;
-      pp_close_box ppf () ;
-      expression_eo ppf eo false;
-
-and expression_sequence ppf ?(skip=1) ?(indent=indent) ?(first=true) expr =
-  if (first = true) then begin
-    pp_open_hvbox ppf 0 ;
-    expression_sequence ppf ~skip:skip ~indent:0 ~first:false expr ;
-    pp_close_box ppf () ;
-  end else
-    match expr.pexp_desc with
-    | Pexp_sequence (e1, e2) ->
-         simple_expr ppf e1 ;
-         fprintf ppf ";" ;
-         pp_print_break ppf skip indent ; (* "@;<1 2>" ; *)
-         expression_sequence ppf ~skip:skip ~indent:indent ~first:false e2 ;
-    | _ ->
-         expression ppf expr ;
-
-and expression_list_helper ppf exp =
-  match exp with
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)}
-     -> () ;
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") },
-                   Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
-     -> fprintf ppf ";@ " ;
-        simple_expr ppf exp1 ;
-        expression_list_helper ppf exp2 ;
-  | {pexp_desc = _}
-     -> assert false;
-
-and expression_list_nonterminal ppf exp =
-  match exp with
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)}
-     -> fprintf ppf "[]" ; (* assert false; *)
-  | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") },
-                   Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)}
-     -> simple_expr ppf exp1;
-        fprintf ppf " ::@ ";
-        expression_list_nonterminal ppf exp2;
-  | {pexp_desc = _}
-     -> expression ppf exp;
-;
-
-and directive_argument ppf x =
-  match x with
-  | Pdir_none -> ()
-  | Pdir_string (s) -> fprintf ppf "@ \"%s\"" s;
-  | Pdir_int (i) -> fprintf ppf "@ %d" i;
-  | Pdir_ident (li) -> fprintf ppf "@ %a" fmt_longident_aux li;
-  | Pdir_bool (b) -> fprintf ppf "@ %s" (string_of_bool b);
-
-and string_x_core_type_list ppf (s, l) =
-  string ppf s;
-  list core_type ppf l;
-
-and string_list_x_location ppf (l, loc) =
-  line 0 ppf " %a\n" fmt_location loc;
-  list string ppf l;
-
-and pattern_x_expression_case_single ppf (p, e) eo lbl =
-  (match eo with
-     None ->   pattern_with_label ppf p lbl
-    | Some x ->
-        fprintf ppf "?" ;
-        pp_open_hovbox ppf indent ;
-        fprintf ppf "(" ;
-        begin
-          match p.ppat_desc with
-            Ppat_constraint ({ ppat_desc = Ppat_var s }, ct) ->
-              fprintf ppf "%s@ :@ %a" s.txt core_type ct
-          | Ppat_var s ->
-              fprintf ppf "%s" s.txt
-          | _ -> assert false
-        end;
-        fprintf ppf " =@ " ;
-        expression ppf x ;
-        fprintf ppf ")" ;
-        pp_close_box ppf ()
-  ) ;
-  fprintf ppf " ->@ " ;
-  expression_sequence ppf ~indent:0 e ;;
-
-let rec toplevel_phrase ppf x =
-  match x with
-  | Ptop_def (s) ->
-      pp_open_hvbox ppf 0;
-      list2 structure_item ppf s ~breakfirst:false ~indent:0 "";
-      pp_close_box ppf ();
-  | Ptop_dir (s, da) ->
-      pp_open_hovbox ppf indent;
-      fprintf ppf "#%s" s;
-      directive_argument ppf da;
-      pp_close_box ppf () ;;
-
-let expression ppf x =
-  fprintf ppf "@[";
-  expression ppf x;
-  fprintf ppf "@]";;
-
-let string_of_expression x =
-  ignore (flush_str_formatter ()) ;
-  let ppf = str_formatter in
-  expression ppf x ;
-  flush_str_formatter () ;;
-
-let toplevel_phrase ppf x =
-  pp_print_newline ppf () ;
-  toplevel_phrase ppf x;
-  fprintf ppf ";;" ;
-  pp_print_newline ppf ();;
-
-let print_structure = structure
-let print_signature = signature
diff --git a/tools/primreq.ml b/tools/primreq.ml
index 909e56d1..aea932f8 100644
--- a/tools/primreq.ml
+++ b/tools/primreq.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: primreq.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Determine the set of C primitives required by the given .cmo and .cma
    files *)
 
diff --git a/tools/profiling.ml b/tools/profiling.ml
index b2ac85b8..5dae8e46 100644
--- a/tools/profiling.ml
+++ b/tools/profiling.ml
@@ -12,8 +12,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: profiling.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Run-time library for profiled programs *)
 
 type profiling_counters = (string * (string * int array)) list
diff --git a/tools/profiling.mli b/tools/profiling.mli
index 654c560f..baedc241 100644
--- a/tools/profiling.mli
+++ b/tools/profiling.mli
@@ -12,8 +12,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: profiling.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Run-time library for profiled programs *)
 
 val counters: (string * (string * int array)) list ref;;
diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml
index 7485ea64..c0c5eb09 100644
--- a/tools/read_cmt.ml
+++ b/tools/read_cmt.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Fabrice Le Fessant, INRIA Saclay                   *)
 (*                                                                     *)
diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml
index 89dc946c..39279320 100644
--- a/tools/scrapelabels.ml
+++ b/tools/scrapelabels.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: scrapelabels.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open StdLabels
 open Lexer301
 
diff --git a/tools/setignore b/tools/setignore
index 2c2e0670..43d37a97 100755
--- a/tools/setignore
+++ b/tools/setignore
@@ -18,16 +18,20 @@
 *.a
 *.so
 *.obj
+*.lib
+*.dll
 
-*.cm[ioxa]
+*.cm[ioxat]
 *.cmx[as]
+*.cmti
 *.annot
 
 *.result
 *.byte
 *.native
 program
-program.exe
+*.exe
+*.exe.manifest
 
 .depend
 .depend.nt
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
new file mode 100644
index 00000000..b02a4d2d
--- /dev/null
+++ b/tools/tast_iter.ml
@@ -0,0 +1,376 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+let opt f = function None -> () | Some x -> f x
+
+let structure sub str =
+  List.iter (sub # structure_item) str.str_items
+
+let structure_item sub x =
+  match x.str_desc with
+  | Tstr_eval exp -> sub # expression exp
+  | Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
+  | Tstr_primitive (_id, _, v) -> sub # value_description v
+  | Tstr_type list ->
+      List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
+  | Tstr_exception (_id, _, decl) -> sub # exception_declaration decl
+  | Tstr_exn_rebind (_id, _, _p, _) -> ()
+  | Tstr_module (_id, _, mexpr) -> sub # module_expr mexpr
+  | Tstr_recmodule list ->
+      List.iter
+        (fun (_id, _, mtype, mexpr) ->
+          sub # module_type mtype;
+          sub # module_expr mexpr
+        )
+        list
+  | Tstr_modtype (_id, _, mtype) -> sub # module_type mtype
+  | Tstr_open _ -> ()
+  | Tstr_class list ->
+      List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
+  | Tstr_class_type list ->
+      List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list
+  | Tstr_include (mexpr, _) -> sub # module_expr mexpr
+
+let value_description sub x =
+  sub # core_type x.val_desc
+
+let type_declaration sub decl =
+  List.iter
+    (fun (ct1, ct2, _loc) -> sub # core_type ct1; sub # core_type ct2)
+    decl.typ_cstrs;
+  begin match decl.typ_kind with
+  | Ttype_abstract -> ()
+  | Ttype_variant list ->
+      List.iter (fun (_s, _, cts, _loc) -> List.iter (sub # core_type) cts) list
+  | Ttype_record list ->
+      List.iter (fun (_s, _, _mut, ct, _loc) -> sub # core_type ct) list
+  end;
+  opt (sub # core_type) decl.typ_manifest
+
+let exception_declaration sub decl =
+  List.iter (sub # core_type) decl.exn_params
+
+let pattern sub pat =
+  let extra = function
+    | Tpat_type _
+    | Tpat_unpack -> ()
+    | Tpat_constraint ct -> sub # core_type ct
+  in
+  List.iter (fun (c, _) -> extra c) pat.pat_extra;
+  match pat.pat_desc with
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l
+  | Tpat_construct (_, _, l, _) -> List.iter (sub # pattern) l
+  | Tpat_variant (_, po, _) -> opt (sub # pattern) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, pat) -> sub # pattern pat) l
+  | Tpat_array l -> List.iter (sub # pattern) l
+  | Tpat_or (p1, p2, _) -> sub # pattern p1; sub # pattern p2
+  | Tpat_alias (p, _, _)
+  | Tpat_lazy p -> sub # pattern p
+
+let expression sub exp =
+  let extra = function
+    | Texp_constraint (cty1, cty2) ->
+        opt (sub # core_type) cty1; opt (sub # core_type) cty2
+    | Texp_open _
+    | Texp_newtype _ -> ()
+    | Texp_poly cto -> opt (sub # core_type) cto
+  in
+  List.iter (function (c, _) -> extra c) exp.exp_extra;
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub # bindings (rec_flag, list);
+      sub # expression exp
+  | Texp_function (_, cases, _) ->
+      sub # bindings (Nonrecursive, cases)
+  | Texp_apply (exp, list) ->
+      sub # expression exp;
+      List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
+  | Texp_match (exp, list, _) ->
+      sub # expression exp;
+      sub # bindings (Nonrecursive, list)
+  | Texp_try (exp, list) ->
+      sub # expression exp;
+      sub # bindings (Nonrecursive, list)
+  | Texp_tuple list ->
+      List.iter (sub # expression) list
+  | Texp_construct (_, _, args, _) ->
+      List.iter (sub # expression) args
+  | Texp_variant (_, expo) ->
+      opt (sub # expression) expo
+  | Texp_record (list, expo) ->
+      List.iter (fun (_, _, exp) -> sub # expression exp) list;
+      opt (sub # expression) expo
+  | Texp_field (exp, _, _label) ->
+      sub # expression exp
+  | Texp_setfield (exp1, _, _label, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_array list ->
+      List.iter (sub # expression) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub # expression exp1;
+      sub # expression exp2;
+      opt (sub # expression) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_while (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
+      sub # expression exp1;
+      sub # expression exp2;
+      sub # expression exp3
+  | Texp_when (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_send (exp, _meth, expo) ->
+      sub # expression exp;
+      opt (sub # expression) expo
+  | Texp_new (_path, _, _) -> ()
+  | Texp_instvar (_, _path, _) -> ()
+  | Texp_setinstvar (_, _, _, exp) ->
+      sub # expression exp
+  | Texp_override (_, list) ->
+      List.iter (fun (_path, _, exp) -> sub # expression exp) list
+  | Texp_letmodule (_id, _, mexpr, exp) ->
+      sub # module_expr mexpr;
+      sub # expression exp
+  | Texp_assert exp -> sub # expression exp
+  | Texp_assertfalse -> ()
+  | Texp_lazy exp -> sub # expression exp
+  | Texp_object (cl, _) ->
+      sub # class_structure cl
+  | Texp_pack (mexpr) ->
+      sub # module_expr mexpr
+
+
+let package_type sub pack =
+  List.iter (fun (_s, ct) -> sub # core_type ct) pack.pack_fields
+
+let signature sub sg =
+  List.iter (sub # signature_item) sg.sig_items
+
+let signature_item sub item =
+  match item.sig_desc with
+  | Tsig_value (_id, _, v) ->
+      sub # value_description v
+  | Tsig_type list ->
+      List.iter (fun (_id, _, decl) -> sub # type_declaration decl) list
+  | Tsig_exception (_id, _, decl) ->
+      sub # exception_declaration decl
+  | Tsig_module (_id, _, mtype) ->
+      sub # module_type mtype
+  | Tsig_recmodule list ->
+      List.iter (fun (_id, _, mtype) -> sub # module_type mtype) list
+  | Tsig_modtype (_id, _, mdecl) ->
+      sub # modtype_declaration mdecl
+  | Tsig_open _ -> ()
+  | Tsig_include (mty,_) -> sub # module_type mty
+  | Tsig_class list ->
+      List.iter (sub # class_description) list
+  | Tsig_class_type list ->
+      List.iter (sub # class_type_declaration) list
+
+let modtype_declaration sub mdecl =
+  match mdecl with
+  | Tmodtype_abstract -> ()
+  | Tmodtype_manifest mtype -> sub # module_type mtype
+
+let class_description sub cd =
+  sub # class_type cd.ci_expr
+
+let class_type_declaration sub cd =
+  sub # class_type cd.ci_expr
+
+let module_type sub mty =
+  match mty.mty_desc with
+  | Tmty_ident (_path, _) -> ()
+  | Tmty_signature sg -> sub # signature sg
+  | Tmty_functor (_id, _, mtype1, mtype2) ->
+      sub # module_type mtype1; sub # module_type mtype2
+  | Tmty_with (mtype, list) ->
+      sub # module_type mtype;
+      List.iter (fun (_, _, withc) -> sub # with_constraint withc) list
+  | Tmty_typeof mexpr ->
+      sub # module_expr mexpr
+
+let with_constraint sub cstr =
+  match cstr with
+  | Twith_type decl -> sub # type_declaration decl
+  | Twith_module _ -> ()
+  | Twith_typesubst decl -> sub # type_declaration decl
+  | Twith_modsubst _ -> ()
+
+let module_expr sub mexpr =
+  match mexpr.mod_desc with
+  | Tmod_ident (_p, _) -> ()
+  | Tmod_structure st -> sub # structure st
+  | Tmod_functor (_id, _, mtype, mexpr) ->
+      sub # module_type mtype;
+      sub # module_expr mexpr
+  | Tmod_apply (mexp1, mexp2, _) ->
+      sub # module_expr mexp1;
+      sub # module_expr mexp2
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+      sub # module_expr mexpr
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+      sub # module_expr mexpr;
+      sub # module_type mtype
+  | Tmod_unpack (exp, _mty) ->
+      sub # expression exp
+(*          sub # module_type mty *)
+
+let class_expr sub cexpr =
+  match cexpr.cl_desc with
+  | Tcl_constraint (cl, None, _, _, _ ) ->
+      sub # class_expr cl;
+  | Tcl_structure clstr -> sub # class_structure clstr
+  | Tcl_fun (_label, pat, priv, cl, _partial) ->
+      sub # pattern pat;
+      List.iter (fun (_id, _, exp) -> sub # expression exp) priv;
+      sub # class_expr cl
+  | Tcl_apply (cl, args) ->
+      sub # class_expr cl;
+      List.iter (fun (_label, expo, _) -> opt (sub # expression) expo) args
+  | Tcl_let (rec_flat, bindings, ivars, cl) ->
+      sub # bindings (rec_flat, bindings);
+      List.iter (fun (_id, _, exp) -> sub # expression exp) ivars;
+      sub # class_expr cl
+  | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
+      sub # class_expr cl;
+      sub # class_type clty
+  | Tcl_ident (_, _, tyl) ->
+      List.iter (sub # core_type) tyl
+
+let class_type sub ct =
+  match ct.cltyp_desc with
+  | Tcty_signature csg -> sub # class_signature csg
+  | Tcty_constr (_path, _, list) -> List.iter (sub # core_type) list
+  | Tcty_fun (_label, ct, cl) ->
+      sub # core_type ct;
+      sub # class_type cl
+
+let class_signature sub cs =
+  sub # core_type cs.csig_self;
+  List.iter (sub # class_type_field) cs.csig_fields
+
+let class_type_field sub ctf =
+  match ctf.ctf_desc with
+  | Tctf_inher ct -> sub # class_type ct
+  | Tctf_val (_s, _mut, _virt, ct) ->
+      sub # core_type ct
+  | Tctf_virt  (_s, _priv, ct) ->
+      sub # core_type ct
+  | Tctf_meth  (_s, _priv, ct) ->
+      sub # core_type ct
+  | Tctf_cstr  (ct1, ct2) ->
+      sub # core_type ct1;
+      sub # core_type ct2
+
+let core_type sub ct =
+  match ct.ctyp_desc with
+  | Ttyp_any -> ()
+  | Ttyp_var _s -> ()
+  | Ttyp_arrow (_label, ct1, ct2) ->
+      sub # core_type ct1;
+      sub # core_type ct2
+  | Ttyp_tuple list -> List.iter (sub # core_type) list
+  | Ttyp_constr (_path, _, list) ->
+      List.iter (sub # core_type) list
+  | Ttyp_object list ->
+      List.iter (sub # core_field_type) list
+  | Ttyp_class (_path, _, list, _labels) ->
+      List.iter (sub # core_type) list
+  | Ttyp_alias (ct, _s) ->
+      sub # core_type ct
+  | Ttyp_variant (list, _bool, _labels) ->
+      List.iter (sub # row_field) list
+  | Ttyp_poly (_list, ct) -> sub # core_type ct
+  | Ttyp_package pack -> sub # package_type pack
+
+let core_field_type sub cft =
+  match cft.field_desc with
+  | Tcfield_var -> ()
+  | Tcfield (_s, ct) -> sub # core_type ct
+
+let class_structure sub cs =
+  sub # pattern cs.cstr_pat;
+  List.iter (sub # class_field) cs.cstr_fields
+
+let row_field sub rf =
+  match rf with
+  | Ttag (_label, _bool, list) -> List.iter (sub # core_type) list
+  | Tinherit ct -> sub # core_type ct
+
+let class_field sub cf =
+  match cf.cf_desc with
+  | Tcf_inher (_ovf, cl, _super, _vals, _meths) ->
+      sub # class_expr cl
+  | Tcf_constr (cty, cty') ->
+      sub # core_type cty;
+      sub # core_type cty'
+  | Tcf_val (_lab, _, _, _mut, Tcfk_virtual cty, _override) ->
+      sub # core_type cty
+  | Tcf_val (_lab, _, _, _mut, Tcfk_concrete exp, _override) ->
+      sub # expression exp
+  | Tcf_meth (_lab, _, _priv, Tcfk_virtual cty, _override) ->
+      sub # core_type cty
+  | Tcf_meth (_lab, _, _priv, Tcfk_concrete exp, _override) ->
+      sub # expression exp
+  | Tcf_init exp ->
+      sub # expression exp
+
+let bindings sub (_rec_flag, list) =
+  List.iter (sub # binding) list
+
+let binding sub (pat, exp) =
+  sub # pattern pat;
+  sub # expression exp
+
+class iter = object(this)
+  method binding = binding this
+  method bindings = bindings this
+  method class_description = class_description this
+  method class_expr = class_expr this
+  method class_field = class_field this
+  method class_signature = class_signature this
+  method class_structure = class_structure this
+  method class_type = class_type this
+  method class_type_declaration = class_type_declaration this
+  method class_type_field = class_type_field this
+  method core_field_type = core_field_type this
+  method core_type = core_type this
+  method exception_declaration = exception_declaration this
+  method expression = expression this
+  method modtype_declaration = modtype_declaration this
+  method module_expr = module_expr this
+  method module_type = module_type this
+  method package_type = package_type this
+  method pattern = pattern this
+  method row_field = row_field this
+  method signature = signature this
+  method signature_item = signature_item this
+  method structure = structure this
+  method structure_item = structure_item this
+  method type_declaration = type_declaration this
+  method value_description = value_description this
+  method with_constraint = with_constraint this
+end
diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli
new file mode 100644
index 00000000..cc9bbcae
--- /dev/null
+++ b/tools/tast_iter.mli
@@ -0,0 +1,80 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+class iter: object
+  method binding: (pattern * expression) -> unit
+  method bindings: (rec_flag * (pattern * expression) list) -> unit
+  method class_description: class_description -> unit
+  method class_expr: class_expr -> unit
+  method class_field: class_field -> unit
+  method class_signature: class_signature -> unit
+  method class_structure: class_structure -> unit
+  method class_type: class_type -> unit
+  method class_type_declaration: class_type_declaration -> unit
+  method class_type_field: class_type_field -> unit
+  method core_field_type: core_field_type -> unit
+  method core_type: core_type -> unit
+  method exception_declaration: exception_declaration -> unit
+  method expression: expression -> unit
+  method modtype_declaration: modtype_declaration -> unit
+  method module_expr: module_expr -> unit
+  method module_type: module_type -> unit
+  method package_type: package_type -> unit
+  method pattern: pattern -> unit
+  method row_field: row_field -> unit
+  method signature: signature -> unit
+  method signature_item: signature_item -> unit
+  method structure: structure -> unit
+  method structure_item: structure_item -> unit
+  method type_declaration: type_declaration -> unit
+  method value_description: value_description -> unit
+  method with_constraint: with_constraint -> unit
+end
+(** Recursive iterator class. By inheriting from it and
+    overriding selected methods, it is possible to implement
+    custom behavior for specific kinds of nodes. *)
+
+(** {2 One-level iterators} *)
+
+(** The following functions apply the provided iterator to each
+    sub-component of the argument. *)
+
+val binding: iter -> (pattern * expression) -> unit
+val bindings: iter -> (rec_flag * (pattern * expression) list) -> unit
+val class_description: iter -> class_description -> unit
+val class_expr: iter -> class_expr -> unit
+val class_field: iter -> class_field -> unit
+val class_signature: iter -> class_signature -> unit
+val class_structure: iter -> class_structure -> unit
+val class_type: iter -> class_type -> unit
+val class_type_declaration: iter -> class_type_declaration -> unit
+val class_type_field: iter -> class_type_field -> unit
+val core_field_type: iter -> core_field_type -> unit
+val core_type: iter -> core_type -> unit
+val exception_declaration: iter -> exception_declaration -> unit
+val expression: iter -> expression -> unit
+val modtype_declaration: iter -> modtype_declaration -> unit
+val module_expr: iter -> module_expr -> unit
+val module_type: iter -> module_type -> unit
+val package_type: iter -> package_type -> unit
+val pattern: iter -> pattern -> unit
+val row_field: iter -> row_field -> unit
+val signature: iter -> signature -> unit
+val signature_item: iter -> signature_item -> unit
+val structure: iter -> structure -> unit
+val structure_item: iter -> structure_item -> unit
+val type_declaration: iter -> type_declaration -> unit
+val value_description: iter -> value_description -> unit
+val with_constraint: iter -> with_constraint -> unit
diff --git a/tools/typedtreeIter.ml b/tools/typedtreeIter.ml
deleted file mode 100644
index b2191b4d..00000000
--- a/tools/typedtreeIter.ml
+++ /dev/null
@@ -1,645 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*   en Automatique.  All rights reserved.  This file is distributed      *)
-(*   under the terms of the Q Public License version 1.0.                 *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*
-TODO:
- - 2012/05/10: Follow camlp4 way of building map and iter using classes
-     and inheritance ?
-*)
-
-open Asttypes
-open Typedtree
-
-module type IteratorArgument = sig
-
-    val enter_structure : structure -> unit
-    val enter_value_description : value_description -> unit
-    val enter_type_declaration : type_declaration -> unit
-    val enter_exception_declaration :
-      exception_declaration -> unit
-    val enter_pattern : pattern -> unit
-    val enter_expression : expression -> unit
-    val enter_package_type : package_type -> unit
-    val enter_signature : signature -> unit
-    val enter_signature_item : signature_item -> unit
-    val enter_modtype_declaration : modtype_declaration -> unit
-    val enter_module_type : module_type -> unit
-    val enter_module_expr : module_expr -> unit
-    val enter_with_constraint : with_constraint -> unit
-    val enter_class_expr : class_expr -> unit
-    val enter_class_signature : class_signature -> unit
-    val enter_class_declaration : class_declaration -> unit
-    val enter_class_description : class_description -> unit
-    val enter_class_type_declaration : class_type_declaration -> unit
-    val enter_class_type : class_type -> unit
-    val enter_class_type_field : class_type_field -> unit
-    val enter_core_type : core_type -> unit
-    val enter_core_field_type : core_field_type -> unit
-    val enter_class_structure : class_structure -> unit
-    val enter_class_field : class_field -> unit
-    val enter_structure_item : structure_item -> unit
-
-
-    val leave_structure : structure -> unit
-    val leave_value_description : value_description -> unit
-    val leave_type_declaration : type_declaration -> unit
-    val leave_exception_declaration :
-      exception_declaration -> unit
-    val leave_pattern : pattern -> unit
-    val leave_expression : expression -> unit
-    val leave_package_type : package_type -> unit
-    val leave_signature : signature -> unit
-    val leave_signature_item : signature_item -> unit
-    val leave_modtype_declaration : modtype_declaration -> unit
-    val leave_module_type : module_type -> unit
-    val leave_module_expr : module_expr -> unit
-    val leave_with_constraint : with_constraint -> unit
-    val leave_class_expr : class_expr -> unit
-    val leave_class_signature : class_signature -> unit
-    val leave_class_declaration : class_declaration -> unit
-    val leave_class_description : class_description -> unit
-    val leave_class_type_declaration : class_type_declaration -> unit
-    val leave_class_type : class_type -> unit
-    val leave_class_type_field : class_type_field -> unit
-    val leave_core_type : core_type -> unit
-    val leave_core_field_type : core_field_type -> unit
-    val leave_class_structure : class_structure -> unit
-    val leave_class_field : class_field -> unit
-    val leave_structure_item : structure_item -> unit
-
-    val enter_bindings : rec_flag -> unit
-    val enter_binding : pattern -> expression -> unit
-    val leave_binding : pattern -> expression -> unit
-    val leave_bindings : rec_flag -> unit
-
-      end
-
-module MakeIterator(Iter : IteratorArgument) : sig
-
-    val iter_structure : structure -> unit
-    val iter_signature : signature -> unit
-    val iter_structure_item : structure_item -> unit
-    val iter_signature_item : signature_item -> unit
-    val iter_expression : expression -> unit
-    val iter_module_type : module_type -> unit
-    val iter_pattern : pattern -> unit
-    val iter_class_expr : class_expr -> unit
-
-  end = struct
-
-    let may_iter f v =
-      match v with
-        None -> ()
-      | Some x -> f x
-
-
-    open Misc
-    open Asttypes
-
-    let rec iter_structure str =
-      Iter.enter_structure str;
-      List.iter iter_structure_item str.str_items;
-      Iter.leave_structure str
-
-
-    and iter_binding (pat, exp) =
-      Iter.enter_binding pat exp;
-      iter_pattern pat;
-      iter_expression exp;
-      Iter.leave_binding pat exp
-
-    and iter_bindings rec_flag list =
-      Iter.enter_bindings rec_flag;
-      List.iter iter_binding list;
-      Iter.leave_bindings rec_flag
-
-    and iter_structure_item item =
-      Iter.enter_structure_item item;
-      begin
-        match item.str_desc with
-          Tstr_eval exp -> iter_expression exp
-        | Tstr_value (rec_flag, list) ->
-            iter_bindings rec_flag list
-        | Tstr_primitive (id, _, v) -> iter_value_description v
-        | Tstr_type list ->
-            List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
-        | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
-        | Tstr_exn_rebind (id, _, p, _) -> ()
-        | Tstr_module (id, _, mexpr) ->
-            iter_module_expr mexpr
-        | Tstr_recmodule list ->
-            List.iter (fun (id, _, mtype, mexpr) ->
-                iter_module_type mtype;
-                iter_module_expr mexpr) list
-        | Tstr_modtype (id, _, mtype) ->
-            iter_module_type mtype
-        | Tstr_open _ -> ()
-        | Tstr_class list ->
-            List.iter (fun (ci, _, _) ->
-                Iter.enter_class_declaration ci;
-                iter_class_expr ci.ci_expr;
-                Iter.leave_class_declaration ci;
-            ) list
-        | Tstr_class_type list ->
-            List.iter (fun (id, _, ct) ->
-                Iter.enter_class_type_declaration ct;
-                iter_class_type ct.ci_expr;
-                Iter.leave_class_type_declaration ct;
-            ) list
-        | Tstr_include (mexpr, _) ->
-            iter_module_expr mexpr
-      end;
-      Iter.leave_structure_item item
-
-    and iter_value_description v =
-      Iter.enter_value_description v;
-      iter_core_type v.val_desc;
-      Iter.leave_value_description v
-
-    and iter_type_declaration decl =
-      Iter.enter_type_declaration decl;
-      List.iter (fun (ct1, ct2, loc) ->
-          iter_core_type ct1;
-          iter_core_type ct2
-      ) decl.typ_cstrs;
-      begin match decl.typ_kind with
-          Ttype_abstract -> ()
-        | Ttype_variant list ->
-            List.iter (fun (s, _, cts, loc) ->
-                List.iter iter_core_type cts
-            ) list
-        | Ttype_record list ->
-            List.iter (fun (s, _, mut, ct, loc) ->
-                iter_core_type ct
-            ) list
-      end;
-      begin match decl.typ_manifest with
-          None -> ()
-        | Some ct -> iter_core_type ct
-      end;
-      Iter.leave_type_declaration decl
-
-    and iter_exception_declaration decl =
-      Iter.enter_exception_declaration decl;
-      List.iter iter_core_type decl.exn_params;
-      Iter.leave_exception_declaration decl;
-
-    and iter_pattern pat =
-      Iter.enter_pattern pat;
-      List.iter (fun (cstr, _) -> match cstr with
-              | Tpat_type _ -> ()
-              | Tpat_unpack -> ()
-              | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
-      begin
-        match pat.pat_desc with
-          Tpat_any -> ()
-        | Tpat_var (id, _) -> ()
-        | Tpat_alias (pat1, _, _) -> iter_pattern pat1
-        | Tpat_constant cst -> ()
-        | Tpat_tuple list ->
-            List.iter iter_pattern list
-        | Tpat_construct (path, _, _, args, _) ->
-            List.iter iter_pattern args
-        | Tpat_variant (label, pato, _) ->
-            begin match pato with
-                None -> ()
-              | Some pat -> iter_pattern pat
-            end
-        | Tpat_record (list, closed) ->
-            List.iter (fun (path, _, _, pat) -> iter_pattern pat) list
-        | Tpat_array list -> List.iter iter_pattern list
-        | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
-        | Tpat_lazy p -> iter_pattern p
-      end;
-      Iter.leave_pattern pat
-
-    and option f x = match x with None -> () | Some e -> f e
-
-    and iter_expression exp =
-      Iter.enter_expression exp;
-      List.iter (function (cstr, _) ->
-        match cstr with
-          Texp_constraint (cty1, cty2) ->
-            option iter_core_type cty1; option iter_core_type cty2
-        | Texp_open (path, _, _) -> ()
-        | Texp_poly cto -> option iter_core_type cto
-        | Texp_newtype s -> ())
-        exp.exp_extra;
-      begin
-        match exp.exp_desc with
-          Texp_ident (path, _, _) -> ()
-        | Texp_constant cst -> ()
-        | Texp_let (rec_flag, list, exp) ->
-            iter_bindings rec_flag list;
-            iter_expression exp
-        | Texp_function (label, cases, _) ->
-            iter_bindings Nonrecursive cases
-        | Texp_apply (exp, list) ->
-            iter_expression exp;
-            List.iter (fun (label, expo, _) ->
-                match expo with
-                  None -> ()
-                | Some exp -> iter_expression exp
-            ) list
-        | Texp_match (exp, list, _) ->
-            iter_expression exp;
-            iter_bindings Nonrecursive list
-        | Texp_try (exp, list) ->
-            iter_expression exp;
-            iter_bindings Nonrecursive list
-        | Texp_tuple list ->
-            List.iter iter_expression list
-        | Texp_construct (path, _, _, args, _) ->
-            List.iter iter_expression args
-        | Texp_variant (label, expo) ->
-            begin match expo with
-                None -> ()
-              | Some exp -> iter_expression exp
-            end
-        | Texp_record (list, expo) ->
-            List.iter (fun (path, _, _, exp) ->
-                iter_expression exp
-            ) list;
-            begin match expo with
-                None -> ()
-              | Some exp -> iter_expression exp
-            end
-        | Texp_field (exp, path, _, label) ->
-            iter_expression exp
-        | Texp_setfield (exp1, path, _ , label, exp2) ->
-            iter_expression exp1;
-            iter_expression exp2
-        | Texp_array list ->
-            List.iter iter_expression list
-        | Texp_ifthenelse (exp1, exp2, expo) ->
-            iter_expression exp1;
-            iter_expression exp2;
-            begin match expo with
-                None -> ()
-              | Some exp -> iter_expression exp
-            end
-        | Texp_sequence (exp1, exp2) ->
-            iter_expression exp1;
-            iter_expression exp2
-        | Texp_while (exp1, exp2) ->
-            iter_expression exp1;
-            iter_expression exp2
-        | Texp_for (id, _, exp1, exp2, dir, exp3) ->
-            iter_expression exp1;
-            iter_expression exp2;
-            iter_expression exp3
-        | Texp_when (exp1, exp2) ->
-            iter_expression exp1;
-            iter_expression exp2
-        | Texp_send (exp, meth, expo) ->
-            iter_expression exp;
-          begin
-            match expo with
-                None -> ()
-              | Some exp -> iter_expression exp
-          end
-        | Texp_new (path, _, _) -> ()
-        | Texp_instvar (_, path, _) -> ()
-        | Texp_setinstvar (_, _, _, exp) ->
-            iter_expression exp
-        | Texp_override (_, list) ->
-            List.iter (fun (path, _, exp) ->
-                iter_expression exp
-            ) list
-        | Texp_letmodule (id, _, mexpr, exp) ->
-            iter_module_expr mexpr;
-            iter_expression exp
-        | Texp_assert exp -> iter_expression exp
-        | Texp_assertfalse -> ()
-        | Texp_lazy exp -> iter_expression exp
-        | Texp_object (cl, _) ->
-            iter_class_structure cl
-        | Texp_pack (mexpr) ->
-            iter_module_expr mexpr
-      end;
-      Iter.leave_expression exp;
-
-    and iter_package_type pack =
-      Iter.enter_package_type pack;
-      List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
-      Iter.leave_package_type pack;
-
-    and iter_signature sg =
-      Iter.enter_signature sg;
-      List.iter iter_signature_item sg.sig_items;
-      Iter.leave_signature sg;
-
-    and iter_signature_item item =
-      Iter.enter_signature_item item;
-      begin
-        match item.sig_desc with
-          Tsig_value (id, _, v) ->
-            iter_value_description v
-        | Tsig_type list ->
-            List.iter (fun (id, _, decl) ->
-                iter_type_declaration decl
-            ) list
-        | Tsig_exception (id, _, decl) ->
-            iter_exception_declaration decl
-        | Tsig_module (id, _, mtype) ->
-            iter_module_type mtype
-        | Tsig_recmodule list ->
-            List.iter (fun (id, _, mtype) -> iter_module_type mtype) list
-        | Tsig_modtype (id, _, mdecl) ->
-            iter_modtype_declaration mdecl
-        | Tsig_open _ -> ()
-        | Tsig_include (mty,_) -> iter_module_type mty
-        | Tsig_class list ->
-            List.iter iter_class_description list
-        | Tsig_class_type list ->
-            List.iter iter_class_type_declaration list
-      end;
-      Iter.leave_signature_item item;
-
-    and iter_modtype_declaration mdecl =
-      Iter.enter_modtype_declaration mdecl;
-      begin
-        match mdecl with
-          Tmodtype_abstract -> ()
-        | Tmodtype_manifest mtype -> iter_module_type mtype
-      end;
-      Iter.leave_modtype_declaration mdecl;
-
-
-    and iter_class_description cd =
-      Iter.enter_class_description cd;
-      iter_class_type cd.ci_expr;
-      Iter.leave_class_description cd;
-
-    and iter_class_type_declaration cd =
-      Iter.enter_class_type_declaration cd;
-      iter_class_type cd.ci_expr;
-        Iter.leave_class_type_declaration cd;
-
-    and iter_module_type mty =
-      Iter.enter_module_type mty;
-      begin
-        match mty.mty_desc with
-          Tmty_ident (path, _) -> ()
-        | Tmty_signature sg -> iter_signature sg
-        | Tmty_functor (id, _, mtype1, mtype2) ->
-            iter_module_type mtype1; iter_module_type mtype2
-        | Tmty_with (mtype, list) ->
-            iter_module_type mtype;
-            List.iter (fun (path, _, withc) ->
-                iter_with_constraint withc
-            ) list
-        | Tmty_typeof mexpr ->
-            iter_module_expr mexpr
-      end;
-      Iter.leave_module_type mty;
-
-    and iter_with_constraint cstr =
-      Iter.enter_with_constraint cstr;
-      begin
-        match cstr with
-          Twith_type decl -> iter_type_declaration decl
-        | Twith_module _ -> ()
-        | Twith_typesubst decl -> iter_type_declaration decl
-        | Twith_modsubst _ -> ()
-      end;
-      Iter.leave_with_constraint cstr;
-
-    and iter_module_expr mexpr =
-      Iter.enter_module_expr mexpr;
-      begin
-        match mexpr.mod_desc with
-          Tmod_ident (p, _) -> ()
-        | Tmod_structure st -> iter_structure st
-        | Tmod_functor (id, _, mtype, mexpr) ->
-            iter_module_type mtype;
-            iter_module_expr mexpr
-        | Tmod_apply (mexp1, mexp2, _) ->
-            iter_module_expr mexp1;
-            iter_module_expr mexp2
-        | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
-            iter_module_expr mexpr
-        | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
-            iter_module_expr mexpr;
-            iter_module_type mtype
-        | Tmod_unpack (exp, mty) ->
-            iter_expression exp
-(*          iter_module_type mty *)
-      end;
-      Iter.leave_module_expr mexpr;
-
-    and iter_class_expr cexpr =
-      Iter.enter_class_expr cexpr;
-      begin
-        match cexpr.cl_desc with
-        | Tcl_constraint (cl, None, _, _, _ ) ->
-            iter_class_expr cl;
-        | Tcl_structure clstr -> iter_class_structure clstr
-        | Tcl_fun (label, pat, priv, cl, partial) ->
-          iter_pattern pat;
-          List.iter (fun (id, _, exp) -> iter_expression exp) priv;
-          iter_class_expr cl
-
-        | Tcl_apply (cl, args) ->
-            iter_class_expr cl;
-            List.iter (fun (label, expo, _) ->
-                match expo with
-                  None -> ()
-                | Some exp -> iter_expression exp
-            ) args
-
-        | Tcl_let (rec_flat, bindings, ivars, cl) ->
-          iter_bindings rec_flat bindings;
-          List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
-            iter_class_expr cl
-
-        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
-            iter_class_expr cl;
-            iter_class_type clty
-
-        | Tcl_ident (_, _, tyl) ->
-            List.iter iter_core_type tyl
-      end;
-      Iter.leave_class_expr cexpr;
-
-    and iter_class_type ct =
-      Iter.enter_class_type ct;
-      begin
-        match ct.cltyp_desc with
-          Tcty_signature csg -> iter_class_signature csg
-        | Tcty_constr (path, _, list) ->
-            List.iter iter_core_type list
-        | Tcty_fun (label, ct, cl) ->
-            iter_core_type ct;
-            iter_class_type cl
-      end;
-      Iter.leave_class_type ct;
-
-    and iter_class_signature cs =
-      Iter.enter_class_signature cs;
-      iter_core_type cs.csig_self;
-      List.iter iter_class_type_field cs.csig_fields;
-      Iter.leave_class_signature cs
-
-
-    and iter_class_type_field ctf =
-      Iter.enter_class_type_field ctf;
-      begin
-        match ctf.ctf_desc with
-          Tctf_inher ct -> iter_class_type ct
-        | Tctf_val (s, mut, virt, ct) ->
-            iter_core_type ct
-        | Tctf_virt  (s, priv, ct) ->
-            iter_core_type ct
-        | Tctf_meth  (s, priv, ct) ->
-            iter_core_type ct
-        | Tctf_cstr  (ct1, ct2) ->
-            iter_core_type ct1;
-            iter_core_type ct2
-      end;
-      Iter.leave_class_type_field ctf
-
-    and iter_core_type ct =
-      Iter.enter_core_type ct;
-      begin
-        match ct.ctyp_desc with
-          Ttyp_any -> ()
-        | Ttyp_var s -> ()
-        | Ttyp_arrow (label, ct1, ct2) ->
-            iter_core_type ct1;
-            iter_core_type ct2
-        | Ttyp_tuple list -> List.iter iter_core_type list
-        | Ttyp_constr (path, _, list) ->
-            List.iter iter_core_type list
-        | Ttyp_object list ->
-            List.iter iter_core_field_type list
-        | Ttyp_class (path, _, list, labels) ->
-            List.iter iter_core_type list
-        | Ttyp_alias (ct, s) ->
-            iter_core_type ct
-        | Ttyp_variant (list, bool, labels) ->
-            List.iter iter_row_field list
-        | Ttyp_poly (list, ct) -> iter_core_type ct
-        | Ttyp_package pack -> iter_package_type pack
-      end;
-      Iter.leave_core_type ct;
-
-    and iter_core_field_type cft =
-      Iter.enter_core_field_type cft;
-      begin match cft.field_desc with
-          Tcfield_var -> ()
-        | Tcfield (s, ct) -> iter_core_type ct
-      end;
-      Iter.leave_core_field_type cft;
-
-    and iter_class_structure cs =
-      Iter.enter_class_structure cs;
-      iter_pattern cs.cstr_pat;
-      List.iter iter_class_field cs.cstr_fields;
-      Iter.leave_class_structure cs;
-
-
-    and iter_row_field rf =
-      match rf with
-        Ttag (label, bool, list) ->
-          List.iter iter_core_type list
-      | Tinherit ct -> iter_core_type ct
-
-    and iter_class_field cf =
-      Iter.enter_class_field cf;
-      begin
-        match cf.cf_desc with
-          Tcf_inher (ovf, cl, super, _vals, _meths) ->
-          iter_class_expr cl
-      | Tcf_constr (cty, cty') ->
-          iter_core_type cty;
-          iter_core_type cty'
-      | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
-          iter_core_type cty
-      | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
-          iter_expression exp
-      | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
-          iter_core_type cty
-      | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
-          iter_expression exp
-(*      | Tcf_let (rec_flag, bindings, exps) ->
-          iter_bindings rec_flag bindings;
-        List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
-      | Tcf_init exp ->
-          iter_expression exp
-      end;
-      Iter.leave_class_field cf;
-
-  end
-
-module DefaultIteratorArgument = struct
-
-      let enter_structure _ = ()
-      let enter_value_description _ = ()
-      let enter_type_declaration _ = ()
-      let enter_exception_declaration _ = ()
-      let enter_pattern _ = ()
-      let enter_expression _ = ()
-      let enter_package_type _ = ()
-      let enter_signature _ = ()
-      let enter_signature_item _ = ()
-      let enter_modtype_declaration _ = ()
-      let enter_module_type _ = ()
-      let enter_module_expr _ = ()
-      let enter_with_constraint _ = ()
-      let enter_class_expr _ = ()
-      let enter_class_signature _ = ()
-      let enter_class_declaration _ = ()
-      let enter_class_description _ = ()
-      let enter_class_type_declaration _ = ()
-      let enter_class_type _ = ()
-      let enter_class_type_field _ = ()
-      let enter_core_type _ = ()
-      let enter_core_field_type _ = ()
-      let enter_class_structure _ = ()
-    let enter_class_field _ = ()
-    let enter_structure_item _ = ()
-
-
-      let leave_structure _ = ()
-      let leave_value_description _ = ()
-      let leave_type_declaration _ = ()
-      let leave_exception_declaration _ = ()
-      let leave_pattern _ = ()
-      let leave_expression _ = ()
-      let leave_package_type _ = ()
-      let leave_signature _ = ()
-      let leave_signature_item _ = ()
-      let leave_modtype_declaration _ = ()
-      let leave_module_type _ = ()
-      let leave_module_expr _ = ()
-      let leave_with_constraint _ = ()
-      let leave_class_expr _ = ()
-      let leave_class_signature _ = ()
-      let leave_class_declaration _ = ()
-      let leave_class_description _ = ()
-      let leave_class_type_declaration _ = ()
-      let leave_class_type _ = ()
-      let leave_class_type_field _ = ()
-      let leave_core_type _ = ()
-      let leave_core_field_type _ = ()
-      let leave_class_structure _ = ()
-    let leave_class_field _ = ()
-    let leave_structure_item _ = ()
-
-    let enter_binding _ _ = ()
-    let leave_binding _ _ = ()
-
-    let enter_bindings _ = ()
-    let leave_bindings _ = ()
-
-  end
diff --git a/tools/typedtreeIter.mli b/tools/typedtreeIter.mli
deleted file mode 100644
index be9c6eff..00000000
--- a/tools/typedtreeIter.mli
+++ /dev/null
@@ -1,94 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*   en Automatique.  All rights reserved.  This file is distributed      *)
-(*   under the terms of the Q Public License version 1.0.                 *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Asttypes
-open Typedtree
-
-
-module type IteratorArgument = sig
-    val enter_structure : structure -> unit
-    val enter_value_description : value_description -> unit
-    val enter_type_declaration : type_declaration -> unit
-    val enter_exception_declaration :
-      exception_declaration -> unit
-    val enter_pattern : pattern -> unit
-    val enter_expression : expression -> unit
-    val enter_package_type : package_type -> unit
-    val enter_signature : signature -> unit
-    val enter_signature_item : signature_item -> unit
-    val enter_modtype_declaration : modtype_declaration -> unit
-    val enter_module_type : module_type -> unit
-    val enter_module_expr : module_expr -> unit
-    val enter_with_constraint : with_constraint -> unit
-    val enter_class_expr : class_expr -> unit
-    val enter_class_signature : class_signature -> unit
-    val enter_class_declaration : class_declaration -> unit
-    val enter_class_description : class_description -> unit
-    val enter_class_type_declaration : class_type_declaration -> unit
-    val enter_class_type : class_type -> unit
-    val enter_class_type_field : class_type_field -> unit
-    val enter_core_type : core_type -> unit
-    val enter_core_field_type : core_field_type -> unit
-    val enter_class_structure : class_structure -> unit
-    val enter_class_field : class_field -> unit
-    val enter_structure_item : structure_item -> unit
-
-
-      val leave_structure : structure -> unit
-    val leave_value_description : value_description -> unit
-    val leave_type_declaration : type_declaration -> unit
-    val leave_exception_declaration :
-      exception_declaration -> unit
-    val leave_pattern : pattern -> unit
-    val leave_expression : expression -> unit
-    val leave_package_type : package_type -> unit
-    val leave_signature : signature -> unit
-    val leave_signature_item : signature_item -> unit
-    val leave_modtype_declaration : modtype_declaration -> unit
-    val leave_module_type : module_type -> unit
-    val leave_module_expr : module_expr -> unit
-    val leave_with_constraint : with_constraint -> unit
-    val leave_class_expr : class_expr -> unit
-    val leave_class_signature : class_signature -> unit
-    val leave_class_declaration : class_declaration -> unit
-    val leave_class_description : class_description -> unit
-    val leave_class_type_declaration : class_type_declaration -> unit
-    val leave_class_type : class_type -> unit
-    val leave_class_type_field : class_type_field -> unit
-    val leave_core_type : core_type -> unit
-    val leave_core_field_type : core_field_type -> unit
-    val leave_class_structure : class_structure -> unit
-    val leave_class_field : class_field -> unit
-    val leave_structure_item : structure_item -> unit
-
-    val enter_bindings : rec_flag -> unit
-    val enter_binding : pattern -> expression -> unit
-    val leave_binding : pattern -> expression -> unit
-    val leave_bindings : rec_flag -> unit
-
-      end
-
-module MakeIterator :
-  functor
-  (Iter : IteratorArgument) ->
-           sig
-             val iter_structure : structure -> unit
-             val iter_signature : signature -> unit
-    val iter_structure_item : structure_item -> unit
-    val iter_signature_item : signature_item -> unit
-    val iter_expression : expression -> unit
-    val iter_module_type : module_type -> unit
-    val iter_pattern : pattern -> unit
-    val iter_class_expr : class_expr -> unit
-           end
-
-module DefaultIteratorArgument : IteratorArgument
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 50595a66..6cbbc552 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -10,7 +10,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Misc
 open Asttypes
 open Typedtree
 open Parsetree
@@ -48,24 +47,24 @@ and untype_structure_item item =
     | Tstr_value (rec_flag, list) ->
         Pstr_value (rec_flag, List.map (fun (pat, exp) ->
               untype_pattern pat, untype_expression exp) list)
-    | Tstr_primitive (id, name, v) ->
+    | Tstr_primitive (_id, name, v) ->
         Pstr_primitive (name, untype_value_description v)
     | Tstr_type list ->
-        Pstr_type (List.map (fun (id, name, decl) ->
+        Pstr_type (List.map (fun (_id, name, decl) ->
               name, untype_type_declaration decl) list)
-    | Tstr_exception (id, name, decl) ->
+    | Tstr_exception (_id, name, decl) ->
         Pstr_exception (name, untype_exception_declaration decl)
-    | Tstr_exn_rebind (id, name, p, lid) ->
+    | Tstr_exn_rebind (_id, name, _p, lid) ->
         Pstr_exn_rebind (name, lid)
-    | Tstr_module (id, name, mexpr) ->
+    | Tstr_module (_id, name, mexpr) ->
         Pstr_module (name, untype_module_expr mexpr)
     | Tstr_recmodule list ->
-        Pstr_recmodule (List.map (fun (id, name, mtype, mexpr) ->
+        Pstr_recmodule (List.map (fun (_id, name, mtype, mexpr) ->
               name, untype_module_type mtype,
               untype_module_expr mexpr) list)
-    | Tstr_modtype (id, name, mtype) ->
+    | Tstr_modtype (_id, name, mtype) ->
         Pstr_modtype (name, untype_module_type mtype)
-    | Tstr_open (path, lid) -> Pstr_open (lid)
+    | Tstr_open (ovf, _path, lid) -> Pstr_open (ovf, lid)
     | Tstr_class list ->
         Pstr_class (List.map (fun (ci, _, _) ->
               { pci_virt = ci.ci_virt;
@@ -77,7 +76,7 @@ and untype_structure_item item =
               }
           ) list)
     | Tstr_class_type list ->
-        Pstr_class_type (List.map (fun (id, name, ct) ->
+        Pstr_class_type (List.map (fun (_id, _name, ct) ->
               {
                 pci_virt = ct.ci_virt;
                 pci_params = ct.ci_params;
@@ -108,11 +107,11 @@ and untype_type_declaration decl =
     ptype_kind = (match decl.typ_kind with
         Ttype_abstract -> Ptype_abstract
       | Ttype_variant list ->
-          Ptype_variant (List.map (fun (s, name, cts, loc) ->
+          Ptype_variant (List.map (fun (_s, name, cts, loc) ->
                 (name, List.map untype_core_type cts, None, loc)
             ) list)
       | Ttype_record list ->
-          Ptype_record (List.map (fun (s, name, mut, ct, loc) ->
+          Ptype_record (List.map (fun (_s, name, mut, ct, loc) ->
                 (name, mut, untype_core_type ct, loc)
             ) list)
     );
@@ -130,10 +129,12 @@ and untype_exception_declaration decl =
 and untype_pattern pat =
   let desc =
   match pat with
-      { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name) } -> Ppat_unpack name
-    | { pat_extra=[Tpat_type (path, lid), _] } -> Ppat_type lid
-    | { pat_extra= (Tpat_constraint ct, _) :: rem } ->
-        Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct)
+      { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } ->
+        Ppat_unpack name
+    | { pat_extra=[Tpat_type (_path, lid), _]; _ } -> Ppat_type lid
+    | { pat_extra= (Tpat_constraint ct, _) :: rem; _ } ->
+        Ppat_constraint (untype_pattern { pat with pat_extra=rem },
+                         untype_core_type ct)
     | _ ->
     match pat.pat_desc with
       Tpat_any -> Ppat_any
@@ -145,15 +146,16 @@ and untype_pattern pat =
           | _ ->
               Ppat_var name
         end
-    | Tpat_alias (pat, id, name) ->
+    | Tpat_alias (pat, _id, name) ->
         Ppat_alias (untype_pattern pat, name)
     | Tpat_constant cst -> Ppat_constant cst
     | Tpat_tuple list ->
         Ppat_tuple (List.map untype_pattern list)
-    | Tpat_construct (path, lid, _, args, explicit_arity) ->
+    | Tpat_construct (lid, _, args, explicit_arity) ->
         Ppat_construct (lid,
           (match args with
               [] -> None
+            | [arg] -> Some (untype_pattern arg)
             | args -> Some
                   { ppat_desc = Ppat_tuple (List.map untype_pattern args);
                   ppat_loc = pat.pat_loc; }
@@ -163,7 +165,7 @@ and untype_pattern pat =
             None -> None
           | Some pat -> Some (untype_pattern pat))
     | Tpat_record (list, closed) ->
-        Ppat_record (List.map (fun (path, lid, _, pat) ->
+        Ppat_record (List.map (fun (lid, _, pat) ->
               lid, untype_pattern pat) list, closed)
     | Tpat_array list -> Ppat_array (List.map untype_pattern list)
     | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
@@ -183,7 +185,7 @@ and untype_extra (extra, loc) sexp =
         Pexp_constraint (sexp,
                          option untype_core_type cty1,
                          option untype_core_type cty2)
-    | Texp_open (path, lid, _) -> Pexp_open (lid, sexp)
+    | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp)
     | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
     | Texp_newtype s -> Pexp_newtype (s, sexp)
   in
@@ -193,7 +195,7 @@ and untype_extra (extra, loc) sexp =
 and untype_expression exp =
   let desc =
     match exp.exp_desc with
-      Texp_ident (path, lid, _) -> Pexp_ident (lid)
+      Texp_ident (_path, lid, _) -> Pexp_ident (lid)
     | Texp_constant cst -> Pexp_constant cst
     | Texp_let (rec_flag, list, exp) ->
         Pexp_let (rec_flag,
@@ -221,7 +223,7 @@ and untype_expression exp =
               untype_pattern pat, untype_expression exp) list)
     | Texp_tuple list ->
         Pexp_tuple (List.map untype_expression list)
-    | Texp_construct (path, lid, _, args, explicit_arity) ->
+    | Texp_construct (lid, _, args, explicit_arity) ->
         Pexp_construct (lid,
           (match args with
               [] -> None
@@ -235,15 +237,15 @@ and untype_expression exp =
             None -> None
           | Some exp -> Some (untype_expression exp))
     | Texp_record (list, expo) ->
-        Pexp_record (List.map (fun (path, lid, _, exp) ->
+        Pexp_record (List.map (fun (lid, _, exp) ->
               lid, untype_expression exp
           ) list,
           match expo with
             None -> None
           | Some exp -> Some (untype_expression exp))
-    | Texp_field (exp, path, lid, label) ->
+    | Texp_field (exp, lid, _label) ->
         Pexp_field (untype_expression exp, lid)
-    | Texp_setfield (exp1, path, lid, label, exp2) ->
+    | Texp_setfield (exp1, lid, _label, exp2) ->
         Pexp_setfield (untype_expression exp1, lid,
           untype_expression exp2)
     | Texp_array list ->
@@ -258,7 +260,7 @@ and untype_expression exp =
         Pexp_sequence (untype_expression exp1, untype_expression exp2)
     | Texp_while (exp1, exp2) ->
         Pexp_while (untype_expression exp1, untype_expression exp2)
-    | Texp_for (id, name, exp1, exp2, dir, exp3) ->
+    | Texp_for (_id, name, exp1, exp2, dir, exp3) ->
         Pexp_for (name,
           untype_expression exp1, untype_expression exp2,
           dir, untype_expression exp3)
@@ -268,16 +270,16 @@ and untype_expression exp =
         Pexp_send (untype_expression exp, match meth with
             Tmeth_name name -> name
           | Tmeth_val id -> Ident.name id)
-    | Texp_new (path, lid, _) -> Pexp_new (lid)
+    | Texp_new (_path, lid, _) -> Pexp_new (lid)
     | Texp_instvar (_, path, name) ->
       Pexp_ident ({name with txt = lident_of_path path})
-    | Texp_setinstvar (_, path, lid, exp) ->
+    | Texp_setinstvar (_, _path, lid, exp) ->
         Pexp_setinstvar (lid, untype_expression exp)
     | Texp_override (_, list) ->
-        Pexp_override (List.map (fun (path, lid, exp) ->
+        Pexp_override (List.map (fun (_path, lid, exp) ->
               lid, untype_expression exp
           ) list)
-    | Texp_letmodule (id, name, mexpr, exp) ->
+    | Texp_letmodule (_id, name, mexpr, exp) ->
         Pexp_letmodule (name, untype_module_expr mexpr,
           untype_expression exp)
     | Texp_assert exp -> Pexp_assert (untype_expression exp)
@@ -303,23 +305,23 @@ and untype_signature sg =
 and untype_signature_item item =
   let desc =
     match item.sig_desc with
-      Tsig_value (id, name, v) ->
+      Tsig_value (_id, name, v) ->
         Psig_value (name, untype_value_description v)
     | Tsig_type list ->
-        Psig_type (List.map (fun (id, name, decl) ->
+        Psig_type (List.map (fun (_id, name, decl) ->
               name, untype_type_declaration decl
           ) list)
-    | Tsig_exception (id, name, decl) ->
+    | Tsig_exception (_id, name, decl) ->
         Psig_exception (name, untype_exception_declaration decl)
-    | Tsig_module (id, name, mtype) ->
+    | Tsig_module (_id, name, mtype) ->
         Psig_module (name, untype_module_type mtype)
     | Tsig_recmodule list ->
-        Psig_recmodule (List.map (fun (id, name, mtype) ->
+        Psig_recmodule (List.map (fun (_id, name, mtype) ->
               name, untype_module_type mtype) list)
-    | Tsig_modtype (id, name, mdecl) ->
+    | Tsig_modtype (_id, name, mdecl) ->
         Psig_modtype (name, untype_modtype_declaration mdecl)
-    | Tsig_open (path, lid) -> Psig_open (lid)
-    | Tsig_include (mty, lid) -> Psig_include (untype_module_type mty)
+    | Tsig_open (ovf, _path, lid) -> Psig_open (ovf, lid)
+    | Tsig_include (mty, _) -> Psig_include (untype_module_type mty)
     | Tsig_class list ->
         Psig_class (List.map untype_class_description list)
     | Tsig_class_type list ->
@@ -356,14 +358,14 @@ and untype_class_type_declaration cd =
 
 and untype_module_type mty =
   let desc = match mty.mty_desc with
-      Tmty_ident (path, lid) -> Pmty_ident (lid)
+      Tmty_ident (_path, lid) -> Pmty_ident (lid)
     | Tmty_signature sg -> Pmty_signature (untype_signature sg)
-    | Tmty_functor (id, name, mtype1, mtype2) ->
+    | Tmty_functor (_id, name, mtype1, mtype2) ->
         Pmty_functor (name, untype_module_type mtype1,
           untype_module_type mtype2)
     | Tmty_with (mtype, list) ->
         Pmty_with (untype_module_type mtype,
-          List.map (fun (path, lid, withc) ->
+          List.map (fun (_path, lid, withc) ->
               lid, untype_with_constraint withc
           ) list)
     | Tmty_typeof mexpr ->
@@ -377,9 +379,9 @@ and untype_module_type mty =
 and untype_with_constraint cstr =
   match cstr with
     Twith_type decl -> Pwith_type (untype_type_declaration decl)
-  | Twith_module (path, lid) -> Pwith_module (lid)
+  | Twith_module (_path, lid) -> Pwith_module (lid)
   | Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl)
-  | Twith_modsubst (path, lid) -> Pwith_modsubst (lid)
+  | Twith_modsubst (_path, lid) -> Pwith_modsubst (lid)
 
 and untype_module_expr mexpr =
   match mexpr.mod_desc with
@@ -387,9 +389,9 @@ and untype_module_expr mexpr =
       untype_module_expr m
   | _ ->
       let desc = match mexpr.mod_desc with
-          Tmod_ident (p, lid) -> Pmod_ident (lid)
+          Tmod_ident (_p, lid) -> Pmod_ident (lid)
         | Tmod_structure st -> Pmod_structure (untype_structure st)
-        | Tmod_functor (id, name, mtype, mexpr) ->
+        | Tmod_functor (_id, name, mtype, mexpr) ->
             Pmod_functor (name, untype_module_type mtype,
               untype_module_expr mexpr)
         | Tmod_apply (mexp1, mexp2, _) ->
@@ -397,9 +399,9 @@ and untype_module_expr mexpr =
         | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
             Pmod_constraint (untype_module_expr mexpr,
               untype_module_type mtype)
-        | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) ->
+        | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
             assert false
-        | Tmod_unpack (exp, pack) ->
+        | Tmod_unpack (exp, _pack) ->
         Pmod_unpack (untype_expression exp)
         (* TODO , untype_package_type pack) *)
 
@@ -411,12 +413,13 @@ and untype_module_expr mexpr =
 
 and untype_class_expr cexpr =
   let desc = match cexpr.cl_desc with
-    | Tcl_constraint ( { cl_desc = Tcl_ident (path, lid, tyl) }, None, _, _, _ ) ->
+    | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
+                       None, _, _, _ ) ->
         Pcl_constr (lid,
           List.map untype_core_type tyl)
     | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr)
 
-    | Tcl_fun (label, pat, pv, cl, partial) ->
+    | Tcl_fun (label, pat, _pv, cl, _partial) ->
         Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl)
 
     | Tcl_apply (cl, args) ->
@@ -427,13 +430,13 @@ and untype_class_expr cexpr =
               | Some exp -> (label, untype_expression exp) :: list
           ) args [])
 
-    | Tcl_let (rec_flat, bindings, ivars, cl) ->
+    | Tcl_let (rec_flat, bindings, _ivars, cl) ->
         Pcl_let (rec_flat,
           List.map (fun (pat, exp) ->
               (untype_pattern pat, untype_expression exp)) bindings,
           untype_class_expr cl)
 
-    | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+    | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
         Pcl_constraint (untype_class_expr cl,  untype_class_type clty)
 
     | Tcl_ident _ -> assert false
@@ -446,7 +449,7 @@ and untype_class_expr cexpr =
 and untype_class_type ct =
   let desc = match ct.cltyp_desc with
       Tcty_signature csg -> Pcty_signature (untype_class_signature csg)
-    | Tcty_constr (path, lid, list) ->
+    | Tcty_constr (_path, lid, list) ->
         Pcty_constr (lid, List.map untype_core_type list)
     | Tcty_fun (label, ct, cl) ->
         Pcty_fun (label, untype_core_type ct, untype_class_type cl)
@@ -485,12 +488,12 @@ and untype_core_type ct =
     | Ttyp_arrow (label, ct1, ct2) ->
         Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2)
   | Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list)
-    | Ttyp_constr (path, lid, list) ->
+    | Ttyp_constr (_path, lid, list) ->
         Ptyp_constr (lid,
           List.map untype_core_type list)
     | Ttyp_object list ->
         Ptyp_object (List.map untype_core_field_type list)
-    | Ttyp_class (path, lid, list, labels) ->
+    | Ttyp_class (_path, lid, list, labels) ->
         Ptyp_class (lid,
           List.map untype_core_type list, labels)
     | Ttyp_alias (ct, s) ->
@@ -525,15 +528,15 @@ and untype_class_field cf =
         Pcf_inher (ovf, untype_class_expr cl, super)
     | Tcf_constr (cty, cty') ->
         Pcf_constr (untype_core_type cty, untype_core_type cty')
-    | Tcf_val (lab, name, mut, _, Tcfk_virtual cty, override) ->
+    | Tcf_val (_lab, name, mut, _, Tcfk_virtual cty, _override) ->
         Pcf_valvirt (name, mut, untype_core_type cty)
-    | Tcf_val (lab, name, mut, _, Tcfk_concrete exp, override) ->
+    | Tcf_val (_lab, name, mut, _, Tcfk_concrete exp, override) ->
         Pcf_val (name, mut,
           (if override then Override else Fresh),
           untype_expression exp)
-    | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
+    | Tcf_meth (_lab, name, priv, Tcfk_virtual cty, _override) ->
         Pcf_virt (name, priv, untype_core_type cty)
-    | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
+    | Tcf_meth (_lab, name, priv, Tcfk_concrete exp, override) ->
         Pcf_meth (name, priv,
           (if override then Override else Fresh),
           untype_expression exp)
diff --git a/tools/untypeast.mli b/tools/untypeast.mli
index 0e080536..d61fd4fd 100644
--- a/tools/untypeast.mli
+++ b/tools/untypeast.mli
@@ -12,5 +12,6 @@
 
 val untype_structure : Typedtree.structure -> Parsetree.structure
 val untype_signature : Typedtree.signature -> Parsetree.signature
+val untype_expression : Typedtree.expression -> Parsetree.expression
 
 val lident_of_path : Path.t -> Longident.t
diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index c918960f..fa6fd7ca 100644
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -10,12 +10,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: expunge.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* "Expunge" a toplevel by removing compiler modules from the global List.map.
    Usage: expunge    *)
 
-open Sys
 open Misc
 
 module StringSet =
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 62fb0d37..4472155a 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: genprintval.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* To print values *)
 
 open Misc
@@ -156,10 +154,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
 
     let tree_of_constr =
       tree_of_qualified
-        (fun lid env -> (snd (Env.lookup_constructor lid env)).cstr_res)
+        (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
 
     and tree_of_label =
-      tree_of_qualified (fun lid env -> (snd (Env.lookup_label lid env)).lbl_res)
+      tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
 
     (* An abstract type *)
 
@@ -279,8 +277,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                                     ty_list
                                 with
                                   Ctype.Cannot_apply -> abstract_type in
-                              let lid = tree_of_label env path (Ident.name lbl_name) in
-                              let v =
+                              let name = Ident.name lbl_name in
+                              (* PR#5722: print full module path only
+                                 for first record field *)
+                              let lid =
+                                if pos = 0 then tree_of_label env path name
+                                else Oide_ident name
+                              and v =
                                 tree_of_val (depth - 1) (O.field obj pos)
                                   ty_arg
                               in
@@ -351,7 +354,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       try
         (* Attempt to recover the constructor description for the exn
            from its name *)
-        let cstr = snd (Env.lookup_constructor lid env) in
+        let cstr = Env.lookup_constructor lid env in
         let path =
           match cstr.cstr_tag with
             Cstr_exception (p, _) -> p | _ -> raise Not_found in
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 0d1f7081..8ddf0796 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: genprintval.mli 12689 2012-07-10 14:54:19Z doligez $ *)
-
 (* Printing of values *)
 
 open Types
diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index d4add39b..9741d17b 100644
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -10,14 +10,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttopdirs.ml 12058 2012-01-20 14:23:34Z frisch $ *)
-
 (* Toplevel directives *)
 
 open Format
 open Misc
 open Longident
-open Path
 open Types
 open Opttoploop
 
diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli
index 352627f6..8caf71d4 100644
--- a/toplevel/opttopdirs.mli
+++ b/toplevel/opttopdirs.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttopdirs.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The toplevel directives. *)
 
 open Format
diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 9bce61f7..5dffe10e 100644
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -10,12 +10,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttoploop.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
 (* The interactive toplevel loop *)
 
 open Path
-open Lexing
 open Format
 open Config
 open Misc
@@ -23,11 +20,12 @@ open Parsetree
 open Types
 open Typedtree
 open Outcometree
-open Lambda
 
 type res = Ok of Obj.t | Err of string
 type evaluation_outcome = Result of Obj.t | Exception of exn
 
+let _dummy = (Ok (Obj.magic 0), Err "")
+
 external ndl_run_toplevel: string -> string -> res
   = "caml_natdynlink_run_toplevel"
 external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym"
@@ -42,7 +40,9 @@ let need_symbol sym =
   with _ -> true
 
 let dll_run dll entry =
-  match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with
+  match (try Result (Obj.magic (ndl_run_toplevel dll entry))
+         with exn -> Exception exn)
+  with
     | Exception _ as r -> r
     | Result r ->
         match Obj.magic r with
@@ -77,7 +77,7 @@ let rec eval_path = function
 (* To print values *)
 
 module EvalPath = struct
-  type value = Obj.t
+  type valu = Obj.t
   exception Error
   let eval_path p = try eval_path p with _ -> raise Error
   let same_value v1 v2 = (v1 == v2)
@@ -125,8 +125,6 @@ let toplevel_startup_hook = ref (fun () -> ())
 let phrase_seqid = ref 0
 let phrase_name = ref "TOP"
 
-open Lambda
-
 let load_lambda ppf (size, lam) =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
   let slam = Simplif.simplify_lambda lam in
@@ -155,7 +153,7 @@ let load_lambda ppf (size, lam) =
 (* Print the outcome of an evaluation *)
 
 let rec pr_item env = function
-  | Tsig_value(id, decl) :: rem ->
+  | Sig_value(id, decl) :: rem ->
       let tree = Printtyp.tree_of_value_description id decl in
       let valopt =
         match decl.val_kind with
@@ -168,24 +166,24 @@ let rec pr_item env = function
             Some v
       in
       Some (tree, valopt, rem)
-  | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
+  | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
       pr_item env rem
-  | Tsig_type(id, decl, rs) :: rem ->
+  | Sig_type(id, decl, rs) :: rem ->
       let tree = Printtyp.tree_of_type_declaration id decl rs in
       Some (tree, None, rem)
-  | Tsig_exception(id, decl) :: rem ->
+  | Sig_exception(id, decl) :: rem ->
       let tree = Printtyp.tree_of_exception_declaration id decl in
       Some (tree, None, rem)
-  | Tsig_module(id, mty, rs) :: rem ->
+  | Sig_module(id, mty, rs) :: rem ->
       let tree = Printtyp.tree_of_module id mty rs in
       Some (tree, None, rem)
-  | Tsig_modtype(id, decl) :: rem ->
+  | Sig_modtype(id, decl) :: rem ->
       let tree = Printtyp.tree_of_modtype_declaration id decl in
       Some (tree, None, rem)
-  | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
+  | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
       let tree = Printtyp.tree_of_class_declaration id decl rs in
       Some (tree, None, rem)
-  | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+  | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
       let tree = Printtyp.tree_of_cltype_declaration id decl rs in
       Some (tree, None, rem)
   | _ -> None
@@ -228,6 +226,7 @@ let execute_phrase print_outcome ppf phr =
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
       in
+      if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
       Typecore.force_delayed_checks ();
       let res = Translmod.transl_store_phrases !phrase_name str in
       Warnings.check_fatal ();
@@ -239,8 +238,8 @@ let execute_phrase print_outcome ppf phr =
           | Result v ->
               Compilenv.record_global_approx_toplevel ();
               if print_outcome then
-                match str with
-                | [Tstr_eval exp] ->
+                match str.str_items with
+                | [ {str_desc = Tstr_eval exp} ] ->
                     let outv = outval_of_value newenv v exp.exp_type in
                     let ty = Printtyp.tree_of_type_scheme exp.exp_type in
                     Ophr_eval (outv, ty)
@@ -319,6 +318,7 @@ let use_file ppf name =
           List.iter
             (fun ph ->
               if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              if !Clflags.dump_source then Pprintast.top_phrase ppf ph;
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (!parse_use_file lb);
           true
@@ -384,7 +384,7 @@ let refill_lexbuf buffer len =
 let _ =
   Sys.interactive := true;
   Dynlink.init ();
-  Optcompile.init_path();
+  Compmisc.init_path true;
   Clflags.dlcode := true;
   ()
 
@@ -409,7 +409,7 @@ let set_paths () =
   ()
 
 let initialize_toplevel_env () =
-  toplevel_env := Optcompile.initial_env()
+  toplevel_env := Compmisc.initial_env()
 
 (* The interactive loop *)
 
@@ -432,6 +432,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
@@ -448,7 +449,7 @@ let run_script ppf name args =
   Array.blit args 0 Sys.argv 0 len;
   Obj.truncate (Obj.repr Sys.argv) len;
   Arg.current := 0;
-  Optcompile.init_path();
-  toplevel_env := Optcompile.initial_env();
+  Compmisc.init_path true;
+  toplevel_env := Compmisc.initial_env();
   Sys.interactive := false;
   use_silently ppf name
diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index d003f207..3be9a51e 100644
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttoploop.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Format
 
 (* Set the load paths, before running anything *)
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index f5dfa245..43141e8c 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -10,11 +10,10 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttopmain.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
 open Clflags
 
-let usage = "Usage: ocamlnat   [script-file]\noptions are:"
+let usage =
+   "Usage: ocamlnat   [script-file]\noptions are:"
 
 let preload_objects = ref []
 
@@ -76,10 +75,13 @@ module Options = Main_args.Make_opttop_options (struct
   let _noprompt = set noprompt
   let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
+  let _ppx s = Compenv.first_ppx := s :: !Compenv.first_ppx
   let _principal = set principal
+  let _real_paths = set real_paths
   let _rectypes = set recursive_types
   let _strict_sequence = set strict_sequence
   let _S = set keep_asm_file
+  let _short_paths = clear real_paths
   let _stdin () = file_argument ""
   let _unsafe = set fast
   let _version () = print_version ()
@@ -88,9 +90,12 @@ module Options = Main_args.Make_opttop_options (struct
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
 
+  let _dsource = set dump_source
   let _dparsetree = set dump_parsetree
+  let _dtypedtree = set dump_typedtree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
+  let _dclambda = set dump_clambda
   let _dcmm = set dump_cmm
   let _dsel = set dump_selection
   let _dcombine = set dump_combine
diff --git a/toplevel/opttopmain.mli b/toplevel/opttopmain.mli
index d5797b21..74044e51 100644
--- a/toplevel/opttopmain.mli
+++ b/toplevel/opttopmain.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttopmain.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Start the [ocaml] toplevel loop *)
 
 val main: unit -> unit
diff --git a/toplevel/opttopstart.ml b/toplevel/opttopstart.ml
index 252b3d22..9fa9b47f 100644
--- a/toplevel/opttopstart.ml
+++ b/toplevel/opttopstart.ml
@@ -10,6 +10,4 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: opttopstart.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 let _ = Opttopmain.main()
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 56181052..044e94da 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -10,14 +10,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topdirs.ml 12661 2012-07-07 11:41:17Z scherer $ *)
-
 (* Toplevel directives *)
 
 open Format
 open Misc
 open Longident
-open Path
 open Types
 open Cmo_format
 open Trace
@@ -96,7 +93,9 @@ let load_compunit ic filename ppf compunit =
   end
 
 let rec load_file recursive ppf name =
-  let filename = try Some (find_in_path !Config.load_path name) with Not_found -> None in
+  let filename =
+    try Some (find_in_path !Config.load_path name) with Not_found -> None
+  in
   match filename with
   | None -> fprintf ppf "Cannot find file %s.@." name; false
   | Some filename ->
@@ -120,11 +119,16 @@ and really_load_file recursive ppf name filename ic =
       if recursive then
         List.iter
           (function
-            | (Reloc_getglobal id, _) when not (Symtable.is_global_defined id) ->
+            | (Reloc_getglobal id, _)
+              when not (Symtable.is_global_defined id) ->
                 let file = Ident.name id ^ ".cmo" in
-                begin match try Some (Misc.find_in_path_uncap !Config.load_path file) with Not_found -> None with
+                begin match try Some (Misc.find_in_path_uncap !Config.load_path
+                                        file)
+                      with Not_found -> None
+                with
                 | None -> ()
-                | Some file -> if not (load_file recursive ppf file) then raise Load_failed
+                | Some file ->
+                    if not (load_file recursive ppf file) then raise Load_failed
                 end
             | _ -> ()
           )
@@ -160,15 +164,19 @@ let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
 
 let dir_load_rec ppf name = ignore (load_file true ppf name)
 
-let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out))
+let _ = Hashtbl.add directive_table "load_rec"
+                    (Directive_string (dir_load_rec std_out))
 
 let load_file = load_file false
 
 (* Load commands from a file *)
 
 let dir_use ppf name = ignore(Toploop.use_file ppf name)
+let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name)
 
 let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out))
+let _ = Hashtbl.add directive_table "mod_use"
+                    (Directive_string (dir_mod_use std_out))
 
 (* Install, remove a printer *)
 
diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
index ffcecca2..42ea4ddb 100644
--- a/toplevel/topdirs.mli
+++ b/toplevel/topdirs.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topdirs.mli 12661 2012-07-07 11:41:17Z scherer $ *)
-
 (* The toplevel directives. *)
 
 open Format
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 88bd3ccc..636fe15f 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -10,12 +10,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: toploop.ml 12689 2012-07-10 14:54:19Z doligez $ *)
-
 (* The interactive toplevel loop *)
 
 open Path
-open Lexing
 open Format
 open Config
 open Misc
@@ -105,6 +102,23 @@ let print_error = Location.print_error
 let print_warning = Location.print_warning
 let input_name = Location.input_name
 
+let parse_mod_use_file name lb =
+  let modname =
+    String.capitalize (Filename.chop_extension (Filename.basename name))
+  in
+  let items =
+    List.concat
+      (List.map
+         (function Ptop_def s -> s | Ptop_dir _ -> [])
+         (!parse_use_file lb))
+  in
+  [ Ptop_def
+      [ { pstr_desc =
+            Pstr_module ( Location.mknoloc modname ,
+                          { pmod_desc = Pmod_structure items;
+                            pmod_loc = Location.none } );
+          pstr_loc = Location.none } ] ]
+
 (* Hooks for initialization *)
 
 let toplevel_startup_hook = ref (fun () -> ())
@@ -149,7 +163,9 @@ let load_lambda ppf lam =
 
 (* Print the outcome of an evaluation *)
 
-let rec pr_item env = function
+let rec pr_item env items =
+  Printtyp.hide_rec_items items;
+  match items with
   | Sig_value(id, decl) :: rem ->
       let tree = Printtyp.tree_of_value_description id decl in
       let valopt =
@@ -219,6 +235,7 @@ let execute_phrase print_outcome ppf phr =
       let oldenv = !toplevel_env in
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in
+      if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
       let sg' = Typemod.simplify_signature sg in
       ignore (Includemod.signatures oldenv sg sg');
       Typecore.force_delayed_checks ();
@@ -231,13 +248,14 @@ let execute_phrase print_outcome ppf phr =
           match res with
           | Result v ->
               if print_outcome then
-                match str.str_items with
-                | [ { str_desc = Tstr_eval exp }] ->
-                    let outv = outval_of_value newenv v exp.exp_type in
-                    let ty = Printtyp.tree_of_type_scheme exp.exp_type in
-                    Ophr_eval (outv, ty)
-                | [] -> Ophr_signature []
-                | _ -> Ophr_signature (item_list newenv sg')
+                Printtyp.wrap_printing_env oldenv (fun () ->
+                  match str.str_items with
+                  | [ { str_desc = Tstr_eval exp }] ->
+                      let outv = outval_of_value newenv v exp.exp_type in
+                      let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+                      Ophr_eval (outv, ty)
+                  | [] -> Ophr_signature []
+                  | _ -> Ophr_signature (item_list newenv sg'))
               else Ophr_signature []
           | Exception exn ->
               toplevel_env := oldenv;
@@ -287,7 +305,18 @@ let protect r newval body =
 
 let use_print_results = ref true
 
-let use_file ppf name =
+let phrase ppf phr =
+  let phr =
+    match phr with
+    | Ptop_def str ->
+        Ptop_def (Pparse.apply_rewriters ast_impl_magic_number str)
+    | phr -> phr
+  in
+  if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+  if !Clflags.dump_source then Pprintast.top_phrase ppf phr;
+  phr
+
+let use_file ppf wrap_mod name =
   try
     let (filename, ic, must_close) =
       if name = "" then
@@ -307,9 +336,12 @@ let use_file ppf name =
         try
           List.iter
             (fun ph ->
-              if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              let ph = phrase ppf ph in
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
-            (!parse_use_file lb);
+            (if wrap_mod then
+               parse_mod_use_file name lb
+             else
+               !parse_use_file lb);
           true
         with
         | Exit -> false
@@ -319,6 +351,9 @@ let use_file ppf name =
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
+let mod_use_file ppf name = use_file ppf true name
+let use_file ppf name = use_file ppf false name
+
 let use_silently ppf name =
   protect use_print_results false (fun () -> use_file ppf name)
 
@@ -373,7 +408,7 @@ let refill_lexbuf buffer len =
 let _ =
   Sys.interactive := true;
   let crc_intfs = Symtable.init_toplevel() in
-  Compile.init_path();
+  Compmisc.init_path false;
   List.iter
     (fun (name, crc) ->
       Consistbl.set Env.crc_units name crc Sys.executable_name)
@@ -400,7 +435,7 @@ let set_paths () =
   Dll.add_path !load_path
 
 let initialize_toplevel_env () =
-  toplevel_env := Compile.initial_env()
+  toplevel_env := Compmisc.initial_env()
 
 (* The interactive loop *)
 
@@ -422,8 +457,8 @@ let loop ppf =
       Location.reset();
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
-      if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
-      Env.reset_missing_cmis ();
+      let phr = phrase ppf phr  in
+      Env.reset_cache_toplevel ();
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
@@ -440,7 +475,7 @@ let run_script ppf name args =
   Array.blit args 0 Sys.argv 0 len;
   Obj.truncate (Obj.repr Sys.argv) len;
   Arg.current := 0;
-  Compile.init_path();
-  toplevel_env := Compile.initial_env();
+  Compmisc.init_path false;
+  toplevel_env := Compmisc.initial_env();
   Sys.interactive := false;
   use_silently ppf name
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 3b251c88..da607de9 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: toploop.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Format
 
 (* Accessors for the table of toplevel value bindings.  These functions
@@ -57,9 +55,11 @@ val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
            should be printed. Uncaught exceptions are always printed. *)
 val use_file : formatter -> string -> bool
 val use_silently : formatter -> string -> bool
+val mod_use_file : formatter -> string -> bool
         (* Read and execute commands from a file.
            [use_file] prints the types and values of the results.
-           [use_silently] does not print them. *)
+           [use_silently] does not print them.
+           [mod_use_file] wrap the file contents into a module. *)
 val eval_path: Path.t -> Obj.t
         (* Return the toplevel object referred to by the given path *)
 
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 38dc75ca..3b183f9c 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -10,9 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topmain.ml 12085 2012-01-27 12:48:15Z doligez $ *)
-
 open Clflags
+open Compenv
 
 let usage = "Usage: ocaml   [script-file [arguments]]\n\
              options are:"
@@ -73,8 +72,10 @@ module Options = Main_args.Make_bytetop_options (struct
   let _noprompt = set noprompt
   let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
+  let _ppx s = first_ppx := s :: !first_ppx
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _short_paths = clear real_paths
   let _stdin () = file_argument ""
   let _strict_sequence = set strict_sequence
   let _unsafe = set fast
@@ -84,6 +85,8 @@ module Options = Main_args.Make_bytetop_options (struct
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
   let _dparsetree = set dump_parsetree
+  let _dtypedtree = set dump_typedtree
+  let _dsource = set dump_source
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
   let _dinstr = set dump_instr
@@ -93,6 +96,9 @@ end);;
 
 
 let main () =
+  let ppf = Format.err_formatter in
+  Compenv.readenv ppf Before_args;
   Arg.parse Options.list file_argument usage;
-  if not (prepare Format.err_formatter) then exit 2;
+  Compenv.readenv ppf Before_link;
+  if not (prepare ppf) then exit 2;
   Toploop.loop Format.std_formatter
diff --git a/toplevel/topmain.mli b/toplevel/topmain.mli
index 16e0a91b..74044e51 100644
--- a/toplevel/topmain.mli
+++ b/toplevel/topmain.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topmain.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Start the [ocaml] toplevel loop *)
 
 val main: unit -> unit
diff --git a/toplevel/topstart.ml b/toplevel/topstart.ml
index c0ce2874..f03e2aa6 100644
--- a/toplevel/topstart.ml
+++ b/toplevel/topstart.ml
@@ -10,6 +10,4 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: topstart.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 let _ = Topmain.main()
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index 9dd9bf27..60cfb953 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: trace.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The "trace" facility *)
 
 open Format
diff --git a/toplevel/trace.mli b/toplevel/trace.mli
index d8f84d63..41c119e6 100644
--- a/toplevel/trace.mli
+++ b/toplevel/trace.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: trace.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* The "trace" facility *)
 
 open Format
diff --git a/typing/annot.mli b/typing/annot.mli
index ebd242e8..f75d4c19 100644
--- a/typing/annot.mli
+++ b/typing/annot.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: annot.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Data types for annotations (Stypes.ml) *)
 
 type call = Tail | Stack | Inline;;
diff --git a/typing/btype.ml b/typing/btype.ml
index b0abbd89..4f24372f 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Basic operations on core types *)
 
 open Types
@@ -186,6 +184,12 @@ let is_row_name s =
   let l = String.length s in
   if l < 4 then false else String.sub s (l-4) 4 = "#row"
 
+let is_constr_row t =
+  match t.desc with
+    Tconstr (Path.Pident id, _, _) -> is_row_name (Ident.name id)
+  | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
+  | _ -> false
+
 
                   (**********************************)
                   (*  Utilities for type traversal  *)
diff --git a/typing/btype.mli b/typing/btype.mli
index ac863be8..88019ff2 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.mli 12726 2012-07-18 03:34:36Z garrigue $ *)
-
 (* Basic operations on core types *)
 
 open Asttypes
@@ -78,6 +76,7 @@ val proxy: type_expr -> type_expr
 (**** Utilities for private abbreviations with fixed rows ****)
 val has_constr_row: type_expr -> bool
 val is_row_name: string -> bool
+val is_constr_row: type_expr -> bool
 
 (**** Utilities for type traversal ****)
 
diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml
index dee54102..9a017448 100644
--- a/typing/cmt_format.ml
+++ b/typing/cmt_format.ml
@@ -62,787 +62,11 @@ type cmt_infos = {
 type error =
     Not_a_typedtree of string
 
-
-
-
-
-
-
-
 let need_to_clear_env =
   try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
   with Not_found -> true
 
-(* Re-introduce sharing after clearing environments *)
-let env_hcons = Hashtbl.create 133
-let keep_only_summary env =
-  let new_env = Env.keep_only_summary env in
-  try
-    Hashtbl.find env_hcons new_env
-  with Not_found ->
-    Hashtbl.add env_hcons new_env new_env;
-    new_env
-let clear_env_hcons () = Hashtbl.clear env_hcons
-
-
-
-
-module TypedtreeMap : sig
-
-  open Asttypes
-  open Typedtree
-
-  module type MapArgument = sig
-    val enter_structure : structure -> structure
-    val enter_value_description : value_description -> value_description
-    val enter_type_declaration : type_declaration -> type_declaration
-    val enter_exception_declaration :
-      exception_declaration -> exception_declaration
-    val enter_pattern : pattern -> pattern
-    val enter_expression : expression -> expression
-    val enter_package_type : package_type -> package_type
-    val enter_signature : signature -> signature
-    val enter_signature_item : signature_item -> signature_item
-    val enter_modtype_declaration : modtype_declaration -> modtype_declaration
-    val enter_module_type : module_type -> module_type
-    val enter_module_expr : module_expr -> module_expr
-    val enter_with_constraint : with_constraint -> with_constraint
-    val enter_class_expr : class_expr -> class_expr
-    val enter_class_signature : class_signature -> class_signature
-    val enter_class_description : class_description -> class_description
-    val enter_class_type_declaration :
-      class_type_declaration -> class_type_declaration
-    val enter_class_infos : 'a class_infos -> 'a class_infos
-    val enter_class_type : class_type -> class_type
-    val enter_class_type_field : class_type_field -> class_type_field
-    val enter_core_type : core_type -> core_type
-    val enter_core_field_type : core_field_type -> core_field_type
-    val enter_class_structure : class_structure -> class_structure
-    val enter_class_field : class_field -> class_field
-    val enter_structure_item : structure_item -> structure_item
-
-    val leave_structure : structure -> structure
-    val leave_value_description : value_description -> value_description
-    val leave_type_declaration : type_declaration -> type_declaration
-    val leave_exception_declaration :
-      exception_declaration -> exception_declaration
-    val leave_pattern : pattern -> pattern
-    val leave_expression : expression -> expression
-    val leave_package_type : package_type -> package_type
-    val leave_signature : signature -> signature
-    val leave_signature_item : signature_item -> signature_item
-    val leave_modtype_declaration : modtype_declaration -> modtype_declaration
-    val leave_module_type : module_type -> module_type
-    val leave_module_expr : module_expr -> module_expr
-    val leave_with_constraint : with_constraint -> with_constraint
-    val leave_class_expr : class_expr -> class_expr
-    val leave_class_signature : class_signature -> class_signature
-    val leave_class_description : class_description -> class_description
-    val leave_class_type_declaration :
-      class_type_declaration -> class_type_declaration
-    val leave_class_infos : 'a class_infos -> 'a class_infos
-    val leave_class_type : class_type -> class_type
-    val leave_class_type_field : class_type_field -> class_type_field
-    val leave_core_type : core_type -> core_type
-    val leave_core_field_type : core_field_type -> core_field_type
-    val leave_class_structure : class_structure -> class_structure
-    val leave_class_field : class_field -> class_field
-    val leave_structure_item : structure_item -> structure_item
-
-  end
-
-  module MakeMap :
-    functor
-      (Iter : MapArgument) ->
-  sig
-    val map_structure : structure -> structure
-    val map_pattern : pattern -> pattern
-    val map_structure_item : structure_item -> structure_item
-    val map_expression : expression -> expression
-    val map_class_expr : class_expr -> class_expr
-
-    val map_signature : signature -> signature
-    val map_signature_item : signature_item -> signature_item
-    val map_module_type : module_type -> module_type
-  end
-
-  module DefaultMapArgument : MapArgument
-
-end = struct
-
-  open Asttypes
-  open Typedtree
-
-  module type MapArgument = sig
-    val enter_structure : structure -> structure
-    val enter_value_description : value_description -> value_description
-    val enter_type_declaration : type_declaration -> type_declaration
-    val enter_exception_declaration :
-      exception_declaration -> exception_declaration
-    val enter_pattern : pattern -> pattern
-    val enter_expression : expression -> expression
-    val enter_package_type : package_type -> package_type
-    val enter_signature : signature -> signature
-    val enter_signature_item : signature_item -> signature_item
-    val enter_modtype_declaration : modtype_declaration -> modtype_declaration
-    val enter_module_type : module_type -> module_type
-    val enter_module_expr : module_expr -> module_expr
-    val enter_with_constraint : with_constraint -> with_constraint
-    val enter_class_expr : class_expr -> class_expr
-    val enter_class_signature : class_signature -> class_signature
-    val enter_class_description : class_description -> class_description
-    val enter_class_type_declaration :
-      class_type_declaration -> class_type_declaration
-    val enter_class_infos : 'a class_infos -> 'a class_infos
-    val enter_class_type : class_type -> class_type
-    val enter_class_type_field : class_type_field -> class_type_field
-    val enter_core_type : core_type -> core_type
-    val enter_core_field_type : core_field_type -> core_field_type
-    val enter_class_structure : class_structure -> class_structure
-    val enter_class_field : class_field -> class_field
-    val enter_structure_item : structure_item -> structure_item
-
-    val leave_structure : structure -> structure
-    val leave_value_description : value_description -> value_description
-    val leave_type_declaration : type_declaration -> type_declaration
-    val leave_exception_declaration :
-      exception_declaration -> exception_declaration
-    val leave_pattern : pattern -> pattern
-    val leave_expression : expression -> expression
-    val leave_package_type : package_type -> package_type
-    val leave_signature : signature -> signature
-    val leave_signature_item : signature_item -> signature_item
-    val leave_modtype_declaration : modtype_declaration -> modtype_declaration
-    val leave_module_type : module_type -> module_type
-    val leave_module_expr : module_expr -> module_expr
-    val leave_with_constraint : with_constraint -> with_constraint
-    val leave_class_expr : class_expr -> class_expr
-    val leave_class_signature : class_signature -> class_signature
-    val leave_class_description : class_description -> class_description
-    val leave_class_type_declaration :
-      class_type_declaration -> class_type_declaration
-    val leave_class_infos : 'a class_infos -> 'a class_infos
-    val leave_class_type : class_type -> class_type
-    val leave_class_type_field : class_type_field -> class_type_field
-    val leave_core_type : core_type -> core_type
-    val leave_core_field_type : core_field_type -> core_field_type
-    val leave_class_structure : class_structure -> class_structure
-    val leave_class_field : class_field -> class_field
-    val leave_structure_item : structure_item -> structure_item
-
-  end
-
-
-  module MakeMap(Map : MapArgument) = struct
-
-    let may_map f v =
-      match v with
-          None -> v
-        | Some x -> Some (f x)
-
-
-    open Misc
-    open Asttypes
-
-    let rec map_structure str =
-      let str = Map.enter_structure str in
-      let str_items = List.map map_structure_item str.str_items in
-      Map.leave_structure { str with str_items = str_items }
-
-    and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
-
-    and map_bindings rec_flag list =
-      List.map map_binding list
-
-    and map_structure_item item =
-      let item = Map.enter_structure_item item in
-      let str_desc =
-        match item.str_desc with
-            Tstr_eval exp -> Tstr_eval (map_expression exp)
-          | Tstr_value (rec_flag, list) ->
-            Tstr_value (rec_flag, map_bindings rec_flag list)
-          | Tstr_primitive (id, name, v) ->
-            Tstr_primitive (id, name, map_value_description v)
-          | Tstr_type list ->
-            Tstr_type (List.map (
-              fun (id, name, decl) ->
-                (id, name, map_type_declaration decl) ) list)
-          | Tstr_exception (id, name, decl) ->
-            Tstr_exception (id, name, map_exception_declaration decl)
-          | Tstr_exn_rebind (id, name, path, lid) ->
-            Tstr_exn_rebind (id, name, path, lid)
-          | Tstr_module (id, name, mexpr) ->
-            Tstr_module (id, name, map_module_expr mexpr)
-          | Tstr_recmodule list ->
-            let list =
-              List.map (fun (id, name, mtype, mexpr) ->
-                (id, name, map_module_type mtype, map_module_expr mexpr)
-              ) list
-            in
-            Tstr_recmodule list
-          | Tstr_modtype (id, name, mtype) ->
-            Tstr_modtype (id, name, map_module_type mtype)
-          | Tstr_open (path, lid) -> Tstr_open (path, lid)
-          | Tstr_class list ->
-            let list =
-              List.map (fun (ci, string_list, virtual_flag) ->
-                let ci = Map.enter_class_infos ci in
-                let ci_expr = map_class_expr ci.ci_expr in
-                (Map.leave_class_infos { ci with ci_expr = ci_expr},
-                 string_list, virtual_flag)
-              ) list
-            in
-            Tstr_class list
-          | Tstr_class_type list ->
-            let list = List.map (fun (id, name, ct) ->
-              let ct = Map.enter_class_infos ct in
-              let ci_expr = map_class_type ct.ci_expr in
-              (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
-            ) list in
-            Tstr_class_type list
-          | Tstr_include (mexpr, idents) ->
-            Tstr_include (map_module_expr mexpr, idents)
-      in
-      Map.leave_structure_item { item with str_desc = str_desc}
-
-    and map_value_description v =
-      let v = Map.enter_value_description v in
-      let val_desc = map_core_type v.val_desc in
-      Map.leave_value_description { v with val_desc = val_desc }
-
-    and map_type_declaration decl =
-      let decl = Map.enter_type_declaration decl in
-      let typ_cstrs = List.map (fun (ct1, ct2, loc) ->
-        (map_core_type ct1,
-         map_core_type ct2,
-         loc)
-      ) decl.typ_cstrs in
-      let typ_kind = match decl.typ_kind with
-          Ttype_abstract -> Ttype_abstract
-        | Ttype_variant list ->
-          let list = List.map (fun (s, name, cts, loc) ->
-            (s, name, List.map map_core_type cts, loc)
-          ) list in
-          Ttype_variant list
-        | Ttype_record list ->
-          let list =
-            List.map (fun (s, name, mut, ct, loc) ->
-              (s, name, mut, map_core_type ct, loc)
-            ) list in
-          Ttype_record list
-      in
-      let typ_manifest =
-        match decl.typ_manifest with
-            None -> None
-          | Some ct -> Some (map_core_type ct)
-      in
-      Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs;
-        typ_kind = typ_kind; typ_manifest = typ_manifest }
-
-    and map_exception_declaration decl =
-      let decl = Map.enter_exception_declaration decl in
-      let exn_params = List.map map_core_type decl.exn_params in
-      let decl =       { exn_params = exn_params;
-        exn_exn = decl.exn_exn;
-        exn_loc = decl.exn_loc } in
-      Map.leave_exception_declaration decl;
-
-    and map_pattern pat =
-      let pat = Map.enter_pattern pat in
-      let pat_desc =
-        match pat.pat_desc with
-          | Tpat_alias (pat1, p, text) ->
-            let pat1 = map_pattern pat1 in
-            Tpat_alias (pat1, p, text)
-          | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
-          | Tpat_construct (path, lid, cstr_decl, args, arity) ->
-            Tpat_construct (path, lid, cstr_decl,
-                            List.map map_pattern args, arity)
-          | Tpat_variant (label, pato, rowo) ->
-            let pato = match pato with
-                None -> pato
-              | Some pat -> Some (map_pattern pat)
-            in
-            Tpat_variant (label, pato, rowo)
-          | Tpat_record (list, closed) ->
-            Tpat_record (List.map (fun (path, lid, lab_desc, pat) ->
-              (path, lid, lab_desc, map_pattern pat) ) list, closed)
-          | Tpat_array list -> Tpat_array (List.map map_pattern list)
-          | Tpat_or (p1, p2, rowo) ->
-            Tpat_or (map_pattern p1, map_pattern p2, rowo)
-          | Tpat_lazy p -> Tpat_lazy (map_pattern p)
-          | Tpat_constant _
-          | Tpat_any
-          | Tpat_var _ -> pat.pat_desc
-
-      in
-      let pat_extra = List.map map_pat_extra pat.pat_extra in
-      Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra }
-
-    and map_pat_extra pat_extra =
-      match pat_extra with
-        | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type  ct), loc)
-        | (Tpat_type _ | Tpat_unpack), _ -> pat_extra
-
-    and map_expression exp =
-      let exp = Map.enter_expression exp in
-      let exp_desc =
-        match exp.exp_desc with
-            Texp_ident (_, _, _)
-          | Texp_constant _ -> exp.exp_desc
-          | Texp_let (rec_flag, list, exp) ->
-            Texp_let (rec_flag,
-                      map_bindings rec_flag list,
-                      map_expression exp)
-          | Texp_function (label, cases, partial) ->
-            Texp_function (label, map_bindings Nonrecursive cases, partial)
-          | Texp_apply (exp, list) ->
-            Texp_apply (map_expression exp,
-                        List.map (fun (label, expo, optional) ->
-                          let expo =
-                            match expo with
-                                None -> expo
-                              | Some exp -> Some (map_expression exp)
-                          in
-                          (label, expo, optional)
-                        ) list )
-          | Texp_match (exp, list, partial) ->
-            Texp_match (
-              map_expression exp,
-              map_bindings Nonrecursive list,
-              partial
-            )
-          | Texp_try (exp, list) ->
-            Texp_try (
-              map_expression exp,
-              map_bindings Nonrecursive list
-            )
-          | Texp_tuple list ->
-            Texp_tuple (List.map map_expression list)
-          | Texp_construct (path, lid, cstr_desc, args, arity) ->
-            Texp_construct (path, lid, cstr_desc,
-                            List.map map_expression args, arity )
-          | Texp_variant (label, expo) ->
-            let expo =match expo with
-                None -> expo
-              | Some exp -> Some (map_expression exp)
-            in
-            Texp_variant (label, expo)
-          | Texp_record (list, expo) ->
-            let list =
-              List.map (fun (path, lid, lab_desc, exp) ->
-                (path, lid, lab_desc, map_expression exp)
-              ) list in
-            let expo = match expo with
-                None -> expo
-              | Some exp -> Some (map_expression exp)
-            in
-            Texp_record (list, expo)
-          | Texp_field (exp, path, lid, label) ->
-            Texp_field (map_expression exp, path, lid, label)
-          | Texp_setfield (exp1, path, lid, label, exp2) ->
-            Texp_setfield (
-              map_expression exp1,
-              path, lid,
-              label,
-              map_expression exp2)
-          | Texp_array list ->
-            Texp_array (List.map map_expression list)
-          | Texp_ifthenelse (exp1, exp2, expo) ->
-            Texp_ifthenelse (
-              map_expression exp1,
-              map_expression exp2,
-              match expo with
-                  None -> expo
-                | Some exp -> Some (map_expression exp)
-            )
-          | Texp_sequence (exp1, exp2) ->
-            Texp_sequence (
-              map_expression exp1,
-              map_expression exp2
-            )
-          | Texp_while (exp1, exp2) ->
-            Texp_while (
-              map_expression exp1,
-              map_expression exp2
-            )
-          | Texp_for (id, name, exp1, exp2, dir, exp3) ->
-            Texp_for (
-              id, name,
-              map_expression exp1,
-              map_expression exp2,
-              dir,
-              map_expression exp3
-            )
-          | Texp_when (exp1, exp2) ->
-            Texp_when (
-              map_expression exp1,
-              map_expression exp2
-            )
-          | Texp_send (exp, meth, expo) ->
-            Texp_send (map_expression exp, meth, may_map map_expression expo)
-          | Texp_new (path, lid, cl_decl) -> exp.exp_desc
-          | Texp_instvar (_, path, _) -> exp.exp_desc
-          | Texp_setinstvar (path, lid, path2, exp) ->
-            Texp_setinstvar (path, lid, path2, map_expression exp)
-          | Texp_override (path, list) ->
-            Texp_override (
-              path,
-              List.map (fun (path, lid, exp) ->
-                (path, lid, map_expression exp)
-              ) list
-            )
-          | Texp_letmodule (id, name, mexpr, exp) ->
-            Texp_letmodule (
-              id, name,
-              map_module_expr mexpr,
-              map_expression exp
-            )
-          | Texp_assert exp -> Texp_assert (map_expression exp)
-          | Texp_assertfalse -> exp.exp_desc
-          | Texp_lazy exp -> Texp_lazy (map_expression exp)
-          | Texp_object (cl, string_list) ->
-            Texp_object (map_class_structure cl, string_list)
-          | Texp_pack (mexpr) ->
-            Texp_pack (map_module_expr mexpr)
-      in
-      let exp_extra = List.map map_exp_extra exp.exp_extra in
-      Map.leave_expression {
-        exp with
-          exp_desc = exp_desc;
-          exp_extra = exp_extra }
-
-    and map_exp_extra exp_extra =
-      let loc = snd exp_extra in
-      match fst exp_extra with
-        | Texp_constraint (Some ct, None) ->
-          Texp_constraint (Some (map_core_type ct), None), loc
-        | Texp_constraint (None, Some ct) ->
-          Texp_constraint (None, Some (map_core_type ct)), loc
-        | Texp_constraint (Some ct1, Some ct2) ->
-          Texp_constraint (Some (map_core_type ct1),
-                           Some (map_core_type ct2)), loc
-        | Texp_poly (Some ct) ->
-          Texp_poly (Some ( map_core_type ct )), loc
-        | Texp_newtype _
-        | Texp_constraint (None, None)
-        | Texp_open _
-        | Texp_poly None -> exp_extra
-
-
-    and map_package_type pack =
-      let pack = Map.enter_package_type pack in
-      let pack_fields = List.map (
-        fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in
-      Map.leave_package_type { pack with pack_fields = pack_fields }
-
-    and map_signature sg =
-      let sg = Map.enter_signature sg in
-      let sig_items = List.map map_signature_item sg.sig_items in
-      Map.leave_signature { sg with sig_items = sig_items }
-
-    and map_signature_item item =
-      let item = Map.enter_signature_item item in
-      let sig_desc =
-        match item.sig_desc with
-            Tsig_value (id, name, v) ->
-              Tsig_value (id, name, map_value_description v)
-          | Tsig_type list -> Tsig_type (
-            List.map (fun (id, name, decl) ->
-              (id, name, map_type_declaration decl)
-            ) list
-          )
-          | Tsig_exception (id, name, decl) ->
-            Tsig_exception (id, name, map_exception_declaration decl)
-          | Tsig_module (id, name, mtype) ->
-            Tsig_module (id, name, map_module_type mtype)
-          | Tsig_recmodule list ->
-            Tsig_recmodule (List.map (
-              fun (id, name, mtype) ->
-                (id, name, map_module_type mtype) ) list)
-          | Tsig_modtype (id, name, mdecl) ->
-            Tsig_modtype (id, name, map_modtype_declaration mdecl)
-          | Tsig_open (path, lid) -> item.sig_desc
-          | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid)
-          | Tsig_class list -> Tsig_class (List.map map_class_description list)
-          | Tsig_class_type list ->
-            Tsig_class_type (List.map map_class_type_declaration list)
-      in
-      Map.leave_signature_item { item with sig_desc = sig_desc }
-
-    and map_modtype_declaration mdecl =
-      let mdecl = Map.enter_modtype_declaration mdecl in
-      let mdecl =
-        match mdecl with
-            Tmodtype_abstract -> Tmodtype_abstract
-          | Tmodtype_manifest mtype ->
-            Tmodtype_manifest (map_module_type mtype)
-      in
-      Map.leave_modtype_declaration mdecl
-
-
-    and map_class_description cd =
-      let cd = Map.enter_class_description cd in
-      let ci_expr = map_class_type cd.ci_expr in
-      Map.leave_class_description { cd with ci_expr = ci_expr}
-
-    and map_class_type_declaration cd =
-      let cd = Map.enter_class_type_declaration cd in
-      let ci_expr = map_class_type cd.ci_expr in
-      Map.leave_class_type_declaration { cd with ci_expr = ci_expr }
-
-    and map_module_type mty =
-      let mty = Map.enter_module_type mty in
-      let mty_desc =
-        match mty.mty_desc with
-            Tmty_ident (path, lid) -> mty.mty_desc
-          | Tmty_signature sg -> Tmty_signature (map_signature sg)
-          | Tmty_functor (id, name, mtype1, mtype2) ->
-            Tmty_functor (id, name, map_module_type mtype1,
-                          map_module_type mtype2)
-          | Tmty_with (mtype, list) ->
-            Tmty_with (map_module_type mtype,
-                       List.map (fun (path, lid, withc) ->
-                         (path, lid, map_with_constraint withc)
-                       ) list)
-          | Tmty_typeof mexpr ->
-            Tmty_typeof (map_module_expr mexpr)
-      in
-      Map.leave_module_type { mty with mty_desc = mty_desc}
-
-    and map_with_constraint cstr =
-      let cstr = Map.enter_with_constraint cstr in
-      let cstr =
-        match cstr with
-            Twith_type decl -> Twith_type (map_type_declaration decl)
-          | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
-          | Twith_module (path, lid) -> cstr
-          | Twith_modsubst (path, lid) -> cstr
-      in
-      Map.leave_with_constraint cstr
-
-    and map_module_expr mexpr =
-      let mexpr = Map.enter_module_expr mexpr in
-      let mod_desc =
-        match mexpr.mod_desc with
-            Tmod_ident (p, lid) -> mexpr.mod_desc
-          | Tmod_structure st -> Tmod_structure (map_structure st)
-          | Tmod_functor (id, name, mtype, mexpr) ->
-            Tmod_functor (id, name, map_module_type mtype,
-                          map_module_expr mexpr)
-          | Tmod_apply (mexp1, mexp2, coercion) ->
-            Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
-          | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) ->
-            Tmod_constraint (map_module_expr mexpr, mod_type,
-                             Tmodtype_implicit, coercion)
-          | Tmod_constraint (mexpr, mod_type,
-                             Tmodtype_explicit mtype, coercion) ->
-            Tmod_constraint (map_module_expr mexpr, mod_type,
-                             Tmodtype_explicit (map_module_type mtype),
-                             coercion)
-          | Tmod_unpack (exp, mod_type) ->
-            Tmod_unpack (map_expression exp, mod_type)
-      in
-      Map.leave_module_expr { mexpr with mod_desc = mod_desc }
-
-    and map_class_expr cexpr =
-      let cexpr = Map.enter_class_expr cexpr in
-      let cl_desc =
-        match cexpr.cl_desc with
-          | Tcl_constraint (cl, None, string_list1, string_list2, concr ) ->
-            Tcl_constraint (map_class_expr cl, None, string_list1,
-                            string_list2, concr)
-          | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr)
-          | Tcl_fun (label, pat, priv, cl, partial) ->
-            Tcl_fun (label, map_pattern pat,
-                     List.map (fun (id, name, exp) ->
-                       (id, name, map_expression exp)) priv,
-                     map_class_expr cl, partial)
-
-          | Tcl_apply (cl, args) ->
-            Tcl_apply (map_class_expr cl,
-                       List.map (fun (label, expo, optional) ->
-                                     (label, may_map map_expression expo,
-                                      optional)
-                       ) args)
-          | Tcl_let (rec_flat, bindings, ivars, cl) ->
-            Tcl_let (rec_flat, map_bindings rec_flat bindings,
-                     List.map (fun (id, name, exp) ->
-                                   (id, name, map_expression exp)) ivars,
-                     map_class_expr cl)
-
-          | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
-            Tcl_constraint ( map_class_expr cl,
-                             Some (map_class_type clty), vals, meths, concrs)
-
-          | Tcl_ident (id, name, tyl) ->
-            Tcl_ident (id, name, List.map map_core_type tyl)
-      in
-      Map.leave_class_expr { cexpr with cl_desc = cl_desc }
-
-    and map_class_type ct =
-      let ct = Map.enter_class_type ct in
-      let cltyp_desc =
-        match ct.cltyp_desc with
-            Tcty_signature csg -> Tcty_signature (map_class_signature csg)
-          | Tcty_constr (path, lid, list) ->
-            Tcty_constr (path, lid, List.map map_core_type list)
-          | Tcty_fun (label, ct, cl) ->
-            Tcty_fun (label, map_core_type ct, map_class_type cl)
-      in
-      Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
-
-    and map_class_signature cs =
-      let cs = Map.enter_class_signature cs in
-      let csig_self = map_core_type cs.csig_self in
-      let csig_fields = List.map map_class_type_field cs.csig_fields in
-      Map.leave_class_signature { cs with
-        csig_self = csig_self; csig_fields = csig_fields }
-
-
-    and map_class_type_field ctf =
-      let ctf = Map.enter_class_type_field ctf in
-      let ctf_desc =
-        match ctf.ctf_desc with
-            Tctf_inher ct -> Tctf_inher (map_class_type ct)
-          | Tctf_val (s, mut, virt, ct) ->
-            Tctf_val (s, mut, virt, map_core_type ct)
-          | Tctf_virt  (s, priv, ct) ->
-            Tctf_virt (s, priv, map_core_type ct)
-          | Tctf_meth  (s, priv, ct) ->
-            Tctf_meth (s, priv, map_core_type ct)
-          | Tctf_cstr  (ct1, ct2) ->
-            Tctf_cstr (map_core_type ct1, map_core_type ct2)
-      in
-      Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
-
-    and map_core_type ct =
-      let ct = Map.enter_core_type ct in
-      let ctyp_desc =
-        match ct.ctyp_desc with
-            Ttyp_any
-          | Ttyp_var _ -> ct.ctyp_desc
-          | Ttyp_arrow (label, ct1, ct2) ->
-            Ttyp_arrow (label, map_core_type ct1, map_core_type ct2)
-          | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
-          | Ttyp_constr (path, lid, list) ->
-            Ttyp_constr (path, lid, List.map map_core_type list)
-          | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list)
-          | Ttyp_class (path, lid, list, labels) ->
-            Ttyp_class (path, lid, List.map map_core_type list, labels)
-          | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
-          | Ttyp_variant (list, bool, labels) ->
-            Ttyp_variant (List.map map_row_field list, bool, labels)
-          | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct)
-          | Ttyp_package pack -> Ttyp_package (map_package_type pack)
-      in
-      Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
-
-    and map_core_field_type cft =
-      let cft = Map.enter_core_field_type cft in
-      let field_desc = match cft.field_desc with
-          Tcfield_var -> Tcfield_var
-        | Tcfield (s, ct) -> Tcfield (s, map_core_type ct)
-      in
-      Map.leave_core_field_type { cft with field_desc = field_desc }
-
-    and map_class_structure cs =
-      let cs = Map.enter_class_structure cs in
-      let cstr_pat = map_pattern cs.cstr_pat in
-      let cstr_fields = List.map map_class_field cs.cstr_fields in
-      Map.leave_class_structure { cs with cstr_pat = cstr_pat;
-        cstr_fields = cstr_fields }
-
-    and map_row_field rf =
-      match rf with
-          Ttag (label, bool, list) ->
-            Ttag (label, bool, List.map map_core_type list)
-        | Tinherit ct -> Tinherit (map_core_type ct)
-
-    and map_class_field cf =
-      let cf = Map.enter_class_field cf in
-      let cf_desc =
-        match cf.cf_desc with
-            Tcf_inher (ovf, cl, super, vals, meths) ->
-              Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
-          | Tcf_constr (cty, cty') ->
-            Tcf_constr (map_core_type cty, map_core_type cty')
-          | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
-            Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
-                     override)
-          | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
-            Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
-                     override)
-          | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
-            Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
-                      override)
-          | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
-            Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
-                      override)
-          | Tcf_init exp -> Tcf_init (map_expression exp)
-      in
-      Map.leave_class_field { cf with cf_desc = cf_desc }
-
-  end
-
-module DefaultMapArgument = struct
-
-      let enter_structure t = t
-      let enter_value_description t = t
-      let enter_type_declaration t = t
-      let enter_exception_declaration t = t
-      let enter_pattern t = t
-      let enter_expression t = t
-      let enter_package_type t = t
-      let enter_signature t = t
-      let enter_signature_item t = t
-      let enter_modtype_declaration t = t
-      let enter_module_type t = t
-      let enter_module_expr t = t
-      let enter_with_constraint t = t
-      let enter_class_expr t = t
-      let enter_class_signature t = t
-      let enter_class_description t = t
-      let enter_class_type_declaration t = t
-      let enter_class_infos t = t
-      let enter_class_type t = t
-      let enter_class_type_field t = t
-      let enter_core_type t = t
-      let enter_core_field_type t = t
-      let enter_class_structure t = t
-    let enter_class_field t = t
-    let enter_structure_item t = t
-
-
-      let leave_structure t = t
-      let leave_value_description t = t
-      let leave_type_declaration t = t
-      let leave_exception_declaration t = t
-      let leave_pattern t = t
-      let leave_expression t = t
-      let leave_package_type t = t
-      let leave_signature t = t
-      let leave_signature_item t = t
-      let leave_modtype_declaration t = t
-      let leave_module_type t = t
-      let leave_module_expr t = t
-      let leave_with_constraint t = t
-      let leave_class_expr t = t
-      let leave_class_signature t = t
-      let leave_class_description t = t
-      let leave_class_type_declaration t = t
-      let leave_class_infos t = t
-      let leave_class_type t = t
-      let leave_class_type_field t = t
-      let leave_core_type t = t
-      let leave_core_field_type t = t
-      let leave_class_structure t = t
-    let leave_class_field t = t
-    let leave_structure_item t = t
-
-  end
-
-end
+let keep_only_summary = Env.keep_only_summary
 
 module ClearEnv  = TypedtreeMap.MakeMap (struct
   open TypedtreeMap
@@ -851,8 +75,8 @@ module ClearEnv  = TypedtreeMap.MakeMap (struct
   let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env }
   let leave_expression e =
     let exp_extra = List.map (function
-        (Texp_open (path, lloc, env), loc) ->
-          (Texp_open (path, lloc, keep_only_summary env), loc)
+        (Texp_open (ovf, path, lloc, env), loc) ->
+          (Texp_open (ovf, path, lloc, keep_only_summary env), loc)
       | exp_extra -> exp_extra) e.exp_extra in
     { e with
       exp_env = keep_only_summary e.exp_env;
@@ -878,7 +102,7 @@ module ClearEnv  = TypedtreeMap.MakeMap (struct
 
 end)
 
-let rec clear_part p = match p with
+let clear_part p = match p with
   | Partial_structure s -> Partial_structure (ClearEnv.map_structure s)
   | Partial_structure_item s ->
     Partial_structure_item (ClearEnv.map_structure_item s)
@@ -967,10 +191,7 @@ let get_saved_types () = !saved_types
 let set_saved_types l = saved_types := l
 
 let save_cmt filename modname binary_annots sourcefile initial_env sg =
-  if !Clflags.binary_annotations
-    && not !Clflags.print_types
-    && not !Clflags.dont_write_files
-  then begin
+  if !Clflags.binary_annotations && not !Clflags.print_types then begin
     let imports = Env.imported_units () in
     let oc = open_out_bin filename in
     let this_crc =
@@ -1002,7 +223,6 @@ let save_cmt filename modname binary_annots sourcefile initial_env sg =
       cmt_interface_digest = this_crc;
       cmt_use_summaries = need_to_clear_env;
     } in
-    clear_env_hcons ();
     output_cmt oc cmt;
     close_out oc;
     set_saved_types [];
diff --git a/typing/ctype.ml b/typing/ctype.ml
index f9a0294a..ed461956 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
-
 (* Operations on core types *)
 
 open Misc
@@ -219,8 +217,9 @@ let in_current_module = function
   | Path.Pdot _ | Path.Papply _ -> false
 
 let in_pervasives p =
-    try ignore (Env.find_type p Env.initial); true
-    with Not_found -> false
+  in_current_module p &&
+  try ignore (Env.find_type p Env.initial); true
+  with Not_found -> false
 
 let is_datatype decl=
   match decl.type_kind with
@@ -499,7 +498,7 @@ let free_variables ?env ty =
   unmark_type ty;
   tl
 
-let rec closed_type ty =
+let closed_type ty =
   match free_vars ty with
       []           -> ()
   | (v, real) :: _ -> raise (Non_closed (v, real))
@@ -698,10 +697,9 @@ let get_level env p =
 let rec update_level env level ty =
   let ty = repr ty in
   if ty.level > level then begin
-    if Env.has_local_constraints env then begin
-      match Env.gadt_instance_level env ty with
-        Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
-      | None -> ()
+    begin match Env.gadt_instance_level env ty with
+      Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
+    | None -> ()
     end;
     match ty.desc with
       Tconstr(p, tl, abbrev) when level < get_level env p ->
@@ -733,8 +731,8 @@ let rec update_level env level ty =
         set_level ty level;
         iter_type_expr (update_level env level) ty
     | Tfield(lab, _, ty1, _)
-      when lab = dummy_method && (repr ty1).level > level->
-        raise (Unify [(ty, newvar2 level)])
+      when lab = dummy_method && (repr ty1).level > level ->
+        raise (Unify [(ty1, newvar2 level)])
     | _ ->
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
@@ -755,11 +753,12 @@ let rec generalize_expansive env var_level ty =
         Tconstr (path, tyl, abbrev) ->
           let variance =
             try (Env.find_type path env).type_variance
-            with Not_found -> List.map (fun _ -> (true,true,true)) tyl in
+            with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
           abbrev := Mnil;
           List.iter2
-            (fun (co,cn,ct) t ->
-              if ct then generalize_contravariant env var_level t
+            (fun v t ->
+              if Variance.(mem May_weak v)
+              then generalize_contravariant env var_level t
               else generalize_expansive env var_level t)
             variance tyl
       | Tpackage (_, _, tyl) ->
@@ -983,6 +982,31 @@ let rec copy ?env ?partial ?keep_names ty =
                     if keep then more else newty more.desc
                 |  _ -> assert false
               in
+              let row =
+                match repr more' with (* PR#6163 *)
+                  {desc=Tconstr _} when not row.row_fixed ->
+                    {row with row_fixed = true}
+                | _ -> row
+              in
+              (* Open row if partial for pattern and contains Reither *)
+              let more', row =
+                match partial with
+                  Some (free_univars, false) when row.row_closed
+                  && not row.row_fixed && TypeSet.is_empty (free_univars ty) ->
+                    let not_reither (_, f) =
+                      match row_field_repr f with
+                        Reither _ -> false
+                      | _ -> true
+                    in
+                    if List.for_all not_reither row.row_fields
+                    then (more', row) else
+                    (newty2 (if keep then more.level else !current_level)
+                       (Tvar None),
+                     {row_fields = List.filter not_reither row.row_fields;
+                      row_more = more; row_bound = ();
+                      row_closed = false; row_fixed = false; row_name = None})
+                | _ -> (more', row)
+              in
               (* Register new type first for recursion *)
               more.desc <- Tsubst(newgenty(Ttuple[more';t]));
               (* Return a new copy *)
@@ -1056,8 +1080,6 @@ let new_declaration newtype manifest =
   }
 
 let instance_constructor ?in_pattern cstr =
-  let ty_res = copy cstr.cstr_res in
-  let ty_args = List.map copy cstr.cstr_args in
   begin match in_pattern with
   | None -> ()
   | Some (env, newtype_lev) ->
@@ -1072,10 +1094,14 @@ let instance_constructor ?in_pattern cstr =
           Env.enter_type (get_new_abstract_name name) decl !env in
         env := new_env;
         let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
-        link_type (copy existential) to_unify
+        let tv = copy existential in
+        assert (is_Tvar tv);
+        link_type tv to_unify
       in
       List.iter process cstr.cstr_existentials
   end;
+  let ty_res = copy cstr.cstr_res in
+  let ty_args = List.map copy cstr.cstr_args in
   cleanup_types ();
   (ty_args, ty_res)
 
@@ -1224,7 +1250,7 @@ let instance_label fixed lbl =
 let unify' = (* Forward declaration *)
   ref (fun env ty1 ty2 -> raise (Unify []))
 
-let rec subst env level priv abbrev ty params args body =
+let subst env level priv abbrev ty params args body =
   if List.length params <> List.length args then raise (Unify []);
   let old_level = !current_level in
   current_level := level;
@@ -1334,15 +1360,13 @@ let expand_abbrev_gen kind find_type_expansion env ty =
           | _ -> ()
           end;
           (* For gadts, remember type as non exportable *)
+          (* The ambiguous level registered for ty' should be the highest *)
           if !trace_gadt_instances then begin
-            match lv with
-              Some lv ->
+            match max lv (Env.gadt_instance_level env ty) with
+              None -> ()
+            | Some lv ->
                 if level < lv then raise (Unify [(ty, newvar2 level)]);
                 Env.add_gadt_instances env lv [ty; ty']
-            | None ->
-                match Env.gadt_instance_level env ty with
-                  Some lv -> Env.add_gadt_instances env lv [ty']
-                | None -> ()
           end;
           ty'
       end
@@ -1354,6 +1378,11 @@ let expand_abbrev_gen kind find_type_expansion env ty =
 let expand_abbrev ty =
   expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty
 
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+  try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
 let safe_abbrev env ty =
   let snap = Btype.snapshot () in
   try ignore (expand_abbrev env ty); true
@@ -1361,44 +1390,61 @@ let safe_abbrev env ty =
     Btype.backtrack snap;
     false
 
+(* Expand the head of a type once.
+   Raise Cannot_expand if the type cannot be expanded.
+   May raise Unify, if a recursion was hidden in the type. *)
 let try_expand_once env ty =
   let ty = repr ty in
   match ty.desc with
     Tconstr (p, _, _) -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
-let _ = forward_try_expand_once := try_expand_once
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+  let snap = Btype.snapshot () in
+  try try_expand_once env ty
+  with Unify _ ->
+    Btype.backtrack snap; raise Cannot_expand
 
-(* Fully expand the head of a type.
-   Raise Cannot_expand if the type cannot be expanded.
-   May raise Unify, if a recursion was hidden in the type. *)
-let rec try_expand_head env ty =
-  let ty' = try_expand_once env ty in
-  let ty'' =
-    try try_expand_head env ty'
-    with Cannot_expand -> ty'
-  in
-  if Env.has_local_constraints env then begin
-    match Env.gadt_instance_level env ty'' with
-      None    -> ()
-    | Some lv -> Env.add_gadt_instance_chain env lv ty
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+  let ty' = try_once env ty in
+  try try_expand_head try_once env ty'
+  with Cannot_expand -> ty'
+
+let try_expand_head try_once env ty =
+  let ty' = try_expand_head try_once env ty in
+  begin match Env.gadt_instance_level env ty' with
+    None -> ()
+  | Some lv -> Env.add_gadt_instance_chain env lv ty
   end;
-  ty''
+  ty'
 
-(* Expand once the head of a type *)
-let expand_head_once env ty =
-  try expand_abbrev env (repr ty) with Cannot_expand -> assert false
-
-(* Fully expand the head of a type. *)
+(* Unsafe full expansion, may raise Unify. *)
 let expand_head_unif env ty =
-  try try_expand_head env ty with Cannot_expand -> repr ty
+  try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
 
+(* Safe version of expand_head, never fails *)
 let expand_head env ty =
-  let snap = Btype.snapshot () in
-  try try_expand_head env ty
-  with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
-    Btype.backtrack snap;
-    repr ty
+  try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
+
+(* Expand until we find a non-abstract type declaration *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, p, decl) else
+      let ty =
+        try try_expand_once env ty with Cannot_expand -> raise Not_found
+      in
+      let (_, p', decl) = extract_concrete_typedecl env ty in
+        (p, p', decl)
+  | _ -> raise Not_found
 
 (* Implementing function [expand_head_opt], the compiler's own version of
    [expand_head] used for type-based optimisations.
@@ -1448,7 +1494,7 @@ let enforce_constraints env ty =
 
 (* Recursively expand the head of a type.
    Also expand #-types. *)
-let rec full_expand env ty =
+let full_expand env ty =
   let ty = repr (expand_head env ty) in
   match ty.desc with
     Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
@@ -1469,6 +1515,15 @@ let generic_abbrev env path =
     Not_found ->
       false
 
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
 
                               (*****************)
                               (*  Occur check  *)
@@ -1491,7 +1546,7 @@ let rec non_recursive_abbrev env ty0 ty =
           non_recursive_abbrev env ty0 (try_expand_once_opt env ty)
         with Cannot_expand ->
           if !Clflags.recursive_types &&
-            (in_current_module p || in_pervasives p ||
+            (in_pervasives p ||
              try is_datatype (Env.find_type p env) with Not_found -> false)
           then ()
           else iter_type_expr (non_recursive_abbrev env ty0) ty
@@ -1527,7 +1582,7 @@ let rec occur_rec env visited ty0 ty =
         if List.memq ty visited || !Clflags.recursive_types then raise Occur;
         iter_type_expr (occur_rec env (ty::visited) ty0) ty
       with Occur -> try
-        let ty' = try_expand_head env ty in
+        let ty' = try_expand_head try_expand_once env ty in
         (* Maybe we could simply make a recursive call here,
            but it seems it could make the occur check loop
            (see change in rev. 1.58) *)
@@ -1642,7 +1697,9 @@ let occur_univar env ty =
           begin try
             let td = Env.find_type p env in
             List.iter2
-              (fun t (pos,neg,_) -> if pos || neg then occur_rec bound t)
+              (fun t v ->
+                if Variance.(mem May_pos v || mem May_neg v)
+                then occur_rec bound t)
               tl td.type_variance
           with Not_found ->
             List.iter (occur_rec bound) tl
@@ -1660,7 +1717,7 @@ let add_univars =
 
 let get_univar_family univar_pairs univars =
   if univars = [] then TypeSet.empty else
-  let rec insert s = function
+  let insert s = function
       cl1, (_::_ as cl2) ->
         if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
           add_univars s cl2
@@ -1688,7 +1745,9 @@ let univars_escape env univar_pairs vl ty =
       | Tconstr (p, tl, _) ->
           begin try
             let td = Env.find_type p env in
-            List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur t)
+            List.iter2
+              (fun t v ->
+                if Variance.(mem May_pos v || mem May_neg v) then occur t)
               tl td.type_variance
           with Not_found ->
             List.iter occur tl
@@ -1824,7 +1883,19 @@ let reify env t =
           let t = create_fresh_constr ty.level name in
           link_type ty t
       | Tvariant r ->
-          if not (static_row r) then iterator (row_more r);
+          let r = row_repr r in
+          if not (static_row r) then begin
+            if r.row_fixed then iterator (row_more r) else
+            let m = r.row_more in
+            match m.desc with
+              Tvar o ->
+                let name = match o with Some s -> s | _ -> "ex" in
+                let t = create_fresh_constr m.level name in
+                let row =
+                  {r with row_fields=[]; row_fixed=true; row_more = t} in
+                link_type m (newty2 m.level (Tvariant row))
+            | _ -> assert false
+          end;
           iter_row iterator r
       | Tconstr (p, _, _) when is_object_type p ->
           iter_type_expr iterator (full_expand !env ty)
@@ -1834,14 +1905,18 @@ let reify env t =
   in
   iterator t
 
-let is_abstract_newtype env p =
+let is_newtype env p =
   try
     let decl = Env.find_type p env in
-    not (decl.type_newtype_level = None) &&
-    decl.type_manifest = None &&
-    decl.type_kind = Type_abstract
+    decl.type_newtype_level <> None &&
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public
   with Not_found -> false
 
+let non_aliasable p decl =
+  (* in_pervasives p ||  (subsumed by in_current_module) *)
+  in_current_module p && decl.type_newtype_level = None
+
 (* mcomp type_pairs subst env t1 t2 does not raise an
    exception if it is possible that t1 and t2 are actually
    equal, assuming the types in type_pairs are equal and
@@ -1850,75 +1925,78 @@ let is_abstract_newtype env p =
    and that both their objects and variants are closed
  *)
 
-let rec mcomp type_pairs subst env t1 t2 =
+let rec mcomp type_pairs env t1 t2 =
   if t1 == t2 then () else
   let t1 = repr t1 in
   let t2 = repr t2 in
   if t1 == t2 then () else
-    match (t1.desc, t2.desc) with
-      | (Tvar _, _)
-      | (_, Tvar _)  ->
-        fatal_error "types should not include variables"
-      | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
-        ()
-      | _ ->
-        let t1' = expand_head_opt env t1 in
-        let t2' = expand_head_opt env t2 in
-        (* Expansion may have changed the representative of the types... *)
-        let t1' = repr t1' and t2' = repr t2' in
-        if t1' == t2' then () else
-          begin try TypePairs.find type_pairs (t1', t2')
-          with Not_found ->
-              TypePairs.add type_pairs (t1', t2') ();
-              match (t1'.desc, t2'.desc) with
-                  (Tvar _, Tvar _) -> assert false
-                | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
-                  when l1 = l2 || not (is_optional l1 || is_optional l2) ->
-                  mcomp type_pairs subst env t1 t2;
-                  mcomp type_pairs subst env u1 u2;
-                | (Ttuple tl1, Ttuple tl2) ->
-                  mcomp_list type_pairs subst env tl1 tl2
-                | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
-                  mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2
-                | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
-                  when Path.same p1 p2 && n1 = n2 ->
-                  mcomp_list type_pairs subst env tl1 tl2
-                | (Tvariant row1, Tvariant row2) ->
-                  mcomp_row type_pairs subst env row1 row2
-                | (Tobject (fi1, _), Tobject (fi2, _)) ->
-                  mcomp_fields type_pairs subst env fi1 fi2
-                | (Tfield _, Tfield _) ->       (* Actually unused *)
-                  mcomp_fields type_pairs subst env t1' t2'
-                | (Tnil, Tnil) ->
-                  ()
-                | (Tpoly (t1, []), Tpoly (t2, [])) ->
-                  mcomp type_pairs subst env t1 t2
-                | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
-                  enter_poly env univar_pairs t1 tl1 t2 tl2
-                    (mcomp type_pairs subst env)
-                | (Tunivar _, Tunivar _) ->
-                  unify_univar t1' t2' !univar_pairs
-                | (_, _) ->
-                  raise (Unify [])
-          end
+  match (t1.desc, t2.desc) with
+  | (Tvar _, _)
+  | (_, Tvar _)  ->
+      ()
+  | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+      ()
+  | _ ->
+      let t1' = expand_head_opt env t1 in
+      let t2' = expand_head_opt env t2 in
+      (* Expansion may have changed the representative of the types... *)
+      let t1' = repr t1' and t2' = repr t2' in
+      if t1' == t2' then () else
+      begin try TypePairs.find type_pairs (t1', t2')
+      with Not_found ->
+        TypePairs.add type_pairs (t1', t2') ();
+        match (t1'.desc, t2'.desc) with
+          (Tvar _, Tvar _) -> assert false
+        | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+          when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+            mcomp type_pairs env t1 t2;
+            mcomp type_pairs env u1 u2;
+        | (Ttuple tl1, Ttuple tl2) ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+            mcomp_type_decl type_pairs env p1 p2 tl1 tl2
+        | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) ->
+            let decl = Env.find_type p env in
+            if non_aliasable p decl then raise (Unify [])
+        | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+          when Path.same p1 p2 && n1 = n2 ->
+            mcomp_list type_pairs env tl1 tl2
+        | (Tvariant row1, Tvariant row2) ->
+            mcomp_row type_pairs env row1 row2
+        | (Tobject (fi1, _), Tobject (fi2, _)) ->
+            mcomp_fields type_pairs env fi1 fi2
+        | (Tfield _, Tfield _) ->       (* Actually unused *)
+            mcomp_fields type_pairs env t1' t2'
+        | (Tnil, Tnil) ->
+            ()
+        | (Tpoly (t1, []), Tpoly (t2, [])) ->
+            mcomp type_pairs env t1 t2
+        | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+            enter_poly env univar_pairs t1 tl1 t2 tl2
+              (mcomp type_pairs env)
+        | (Tunivar _, Tunivar _) ->
+            unify_univar t1' t2' !univar_pairs
+        | (_, _) ->
+            raise (Unify [])
+      end
 
-and mcomp_list type_pairs subst env tl1 tl2 =
+and mcomp_list type_pairs env tl1 tl2 =
   if List.length tl1 <> List.length tl2 then
     raise (Unify []);
-  List.iter2 (mcomp type_pairs subst env) tl1 tl2
+  List.iter2 (mcomp type_pairs env) tl1 tl2
 
-and mcomp_fields type_pairs subst env ty1 ty2 =
+and mcomp_fields type_pairs env ty1 ty2 =
   if not (concrete_object ty1 && concrete_object ty2) then assert false;
   let (fields2, rest2) = flatten_fields ty2 in
   let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
-  mcomp type_pairs subst env rest1 rest2;
+  mcomp type_pairs env rest1 rest2;
   if miss1 <> []  && (object_row ty1).desc = Tnil
   || miss2 <> []  && (object_row ty2).desc = Tnil then raise (Unify []);
   List.iter
     (function (n, k1, t1, k2, t2) ->
        mcomp_kind k1 k2;
-       mcomp type_pairs subst env t1 t2)
+       mcomp type_pairs env t1 t2)
     pairs
 
 and mcomp_kind k1 k2 =
@@ -1929,7 +2007,7 @@ and mcomp_kind k1 k2 =
   | (Fpresent, Fpresent) -> ()
   | _                    -> raise (Unify [])
 
-and mcomp_row type_pairs subst env row1 row2 =
+and mcomp_row type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   let cannot_erase (_,f) =
@@ -1948,63 +2026,71 @@ and mcomp_row type_pairs subst env row1 row2 =
       | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
           raise (Unify [])
       | Rpresent(Some t1), Rpresent(Some t2) ->
-          mcomp type_pairs subst env t1 t2
+          mcomp type_pairs env t1 t2
       | Rpresent(Some t1), Reither(false, tl2, _, _) ->
-          List.iter (mcomp type_pairs subst env t1) tl2
+          List.iter (mcomp type_pairs env t1) tl2
       | Reither(false, tl1, _, _), Rpresent(Some t2) ->
-          List.iter (mcomp type_pairs subst env t2) tl1
+          List.iter (mcomp type_pairs env t2) tl1
       | _ -> ())
     pairs
 
-and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 =
-  let non_aliased p decl =
-    in_pervasives p ||
-    in_current_module p && decl.type_newtype_level = None
-  in
+and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
   try
     let decl = Env.find_type p1 env in
     let decl' = Env.find_type p2 env in
-    if Path.same p1 p2 then
-      (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2)
+    if Path.same p1 p2 then begin
+      (* Format.eprintf "@[%a@ %a@]@."
+        !print_raw (newconstr p1 tl2) !print_raw (newconstr p2 tl2);
+      if non_aliasable p1 decl then Format.eprintf "non_aliasable@."
+      else Format.eprintf "aliasable@."; *)
+      let inj =
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
+        with Not_found -> List.map (fun _ -> false) tl1
+      in
+      List.iter2
+        (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2)
+        inj (List.combine tl1 tl2)
+    end
     else match decl.type_kind, decl'.type_kind with
     | Type_record (lst,r), Type_record (lst',r') when r = r' ->
-        mcomp_list type_pairs subst env tl1 tl2;
-        mcomp_record_description type_pairs subst env lst lst'
+        mcomp_list type_pairs env tl1 tl2;
+        mcomp_record_description type_pairs env lst lst'
     | Type_variant v1, Type_variant v2 ->
-        mcomp_list type_pairs subst env tl1 tl2;
-        mcomp_variant_description type_pairs subst env v1 v2
+        mcomp_list type_pairs env tl1 tl2;
+        mcomp_variant_description type_pairs env v1 v2
     | Type_variant _, Type_record _
     | Type_record _, Type_variant _ -> raise (Unify [])
     | _ ->
-        if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl')
-        || is_datatype decl && non_aliased p2 decl' then raise (Unify [])
+        if non_aliasable p1 decl && (non_aliasable p2 decl'||is_datatype decl')
+        || is_datatype decl && non_aliasable p2 decl' then raise (Unify [])
   with Not_found -> ()
 
-and mcomp_type_option type_pairs subst env t t' =
+and mcomp_type_option type_pairs env t t' =
   match t, t' with
     None, None -> ()
-  | Some t, Some t' -> mcomp type_pairs subst env t t'
+  | Some t, Some t' -> mcomp type_pairs env t t'
   | _ -> raise (Unify [])
 
-and mcomp_variant_description type_pairs subst env =
+and mcomp_variant_description type_pairs env xs ys =
   let rec iter = fun x y ->
     match x, y with
-    (name,mflag,t) :: xs, (name', mflag', t') :: ys   ->
-      mcomp_type_option type_pairs subst env t t';
-      if name = name' && mflag = mflag'
+    (id, tl, t) :: xs, (id', tl', t') :: ys   ->
+      mcomp_type_option type_pairs env t t';
+      mcomp_list type_pairs env tl tl';
+      if Ident.name id = Ident.name id'
       then iter xs ys
       else raise (Unify [])
     | [],[] -> ()
     | _ -> raise (Unify [])
   in
-  iter
+  iter xs ys
 
-and mcomp_record_description type_pairs subst env =
+and mcomp_record_description type_pairs env =
   let rec iter = fun x y ->
     match x, y with
-      (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys ->
-        mcomp type_pairs subst env t t';
-        if name = name' && mutable_flag = mutable_flag'
+      (id, mutable_flag, t) :: xs, (id', mutable_flag', t') :: ys ->
+        mcomp type_pairs env t t';
+        if Ident.name id = Ident.name id' && mutable_flag = mutable_flag'
         then iter xs ys
         else raise (Unify [])
     | [], [] -> ()
@@ -2013,7 +2099,7 @@ and mcomp_record_description type_pairs subst env =
   iter
 
 let mcomp env t1 t2 =
-  mcomp (TypePairs.create 4) () env t1 t2
+  mcomp (TypePairs.create 4) env t1 t2
 
 (* Real unification *)
 
@@ -2060,7 +2146,7 @@ let unify_eq env t1 t2 =
 
 let rec unify (env:Env.t ref) t1 t2 =
   (* First step: special cases (optimizations) *)
-  if unify_eq !env t1 t2 then () else
+  if t1 == t2 then () else
   let t1 = repr t1 in
   let t2 = repr t2 in
   if unify_eq !env t1 t2 then () else
@@ -2096,6 +2182,18 @@ let rec unify (env:Env.t ref) t1 t2 =
                  || has_cached_expansion p2 !a2) ->
         update_level !env t1.level t2;
         link_type t1 t2
+    | (Tconstr (p1, [], _), Tconstr (p2, [], _))
+      when Env.has_local_constraints !env
+      && is_newtype !env p1 && is_newtype !env p2 ->
+        (* Do not use local constraints more than necessary *)
+        begin try
+          if find_newtype_level !env p1 < find_newtype_level !env p2 then
+            unify env t1 (try_expand_once !env t2)
+          else
+            unify env (try_expand_once !env t1) t2
+        with Cannot_expand ->
+          unify2 env t1 t2
+        end
     | _ ->
         unify2 env t1 t2
     end;
@@ -2121,13 +2219,12 @@ and unify2 env t1 t2 =
 
   let t1 = repr t1 and t2 = repr t2 in
   if !trace_gadt_instances then begin
-    match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
-      Some lv1, Some lv2 ->
-        if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
-        if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
-    | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
-    | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
-    | None, None     -> ()
+    (* All types in chains already have the same ambiguity levels *)
+    let ilevel t =
+      match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in
+    let lv1 = ilevel t1 and lv2 = ilevel t2 in
+    if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
+    if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1
   end;
   let t1, t2 =
     if !Clflags.principal
@@ -2155,11 +2252,11 @@ and unify3 env t1 t1' t2 t2' =
       unify_univar t1' t2' !univar_pairs;
       link_type t1' t2'
   | (Tvar _, _) ->
-      occur !env t1 t2';
+      occur !env t1' t2;
       occur_univar !env t2;
       link_type t1' t2;
   | (_, Tvar _) ->
-      occur !env t2 t1';
+      occur !env t2' t1;
       occur_univar !env t1;
       link_type t2' t1;
   | (Tfield _, Tfield _) -> (* special case for GADTs *)
@@ -2186,15 +2283,30 @@ and unify3 env t1 t1' t2 t2' =
           unify_list env tl1 tl2
       | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
           if !umode = Expression || not !generate_equations
-          || in_current_module p1 || in_pervasives p1
+          || in_current_module p1 (* || in_pervasives p1 *)
           || try is_datatype (Env.find_type p1 !env) with Not_found -> false
           then
             unify_list env tl1 tl2
           else
-            set_mode Pattern ~generate:false (fun () -> unify_list env tl1 tl2)
+            let inj =
+              try List.map Variance.(mem Inj)
+                    (Env.find_type p1 !env).type_variance
+              with Not_found -> List.map (fun _ -> false) tl1
+            in
+            List.iter2
+              (fun i (t1, t2) ->
+                if i then unify env t1 t2 else
+                set_mode Pattern ~generate:false
+                  begin fun () ->
+                    let snap = snapshot () in
+                    try unify env t1 t2 with Unify _ ->
+                      backtrack snap;
+                      reify env t1; reify env t2
+                  end)
+              inj (List.combine tl1 tl2)
       | (Tconstr ((Path.Pident p) as path,[],_),
          Tconstr ((Path.Pident p') as path',[],_))
-        when is_abstract_newtype !env path && is_abstract_newtype !env path'
+        when is_newtype !env path && is_newtype !env path'
         && !generate_equations ->
           let source,destination =
             if find_newtype_level !env path > find_newtype_level !env path'
@@ -2202,19 +2314,19 @@ and unify3 env t1 t1' t2 t2' =
             else  p',t1'
           in add_gadt_equation env source destination
       | (Tconstr ((Path.Pident p) as path,[],_), _)
-        when is_abstract_newtype !env path && !generate_equations ->
+        when is_newtype !env path && !generate_equations ->
           reify env t2';
           local_non_recursive_abbrev !env (Path.Pident p) t2';
           add_gadt_equation env p t2'
       | (_, Tconstr ((Path.Pident p) as path,[],_))
-        when is_abstract_newtype !env path && !generate_equations ->
+        when is_newtype !env path && !generate_equations ->
           reify env t1' ;
           local_non_recursive_abbrev !env (Path.Pident p) t1';
           add_gadt_equation env p t1'
-      | (Tconstr (_,[],_), _) | (_, Tconstr (_,[],_)) when !umode = Pattern ->
+      | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
           reify env t1';
           reify env t2';
-          mcomp !env t1' t2'
+          if !generate_equations then mcomp !env t1' t2'
       | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
           unify_fields env fi1 fi2;
           (* Type [t2'] may have been instantiated by [unify_fields] *)
@@ -2227,7 +2339,17 @@ and unify3 env t1 t1' t2 t2' =
           | _ -> ()
           end
       | (Tvariant row1, Tvariant row2) ->
-          unify_row env row1 row2
+          if !umode = Expression then
+            unify_row env row1 row2
+          else begin
+            let snap = snapshot () in
+            try unify_row env row1 row2
+            with Unify _ ->
+              backtrack snap;
+              reify env t1';
+              reify env t2';
+              if !generate_equations then mcomp !env t1' t2'
+          end
       | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
           begin match field_kind_repr kind with
             Fvar r when f <> dummy_method ->
@@ -2529,7 +2651,7 @@ let expand_head_trace env t =
    (2) the original label is not optional
 *)
 
-let rec filter_arrow env t l =
+let filter_arrow env t l =
   let t = expand_head_trace env t in
   match t.desc with
     Tvar _ ->
@@ -2572,7 +2694,7 @@ let rec filter_method_field env name priv ty =
       raise (Unify [])
 
 (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
-let rec filter_method env name priv ty =
+let filter_method env name priv ty =
   let ty = expand_head_trace env ty in
   match ty.desc with
     Tvar _ ->
@@ -2648,8 +2770,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
     | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
         ()
     | _ ->
-        let t1' = expand_head_unif env t1 in
-        let t2' = expand_head_unif env t2 in
+        let t1' = expand_head env t1 in
+        let t2' = expand_head env t2 in
         (* Expansion may have changed the representative of the types... *)
         let t1' = repr t1' and t2' = repr t2' in
         if t1' == t2' then () else
@@ -2744,13 +2866,8 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
       raise (Unify [])
   | _ when static_row row1 -> ()
   | _ when may_inst ->
-      if not (static_row row2) then moregen_occur env rm1.level rm2;
-      let ext =
-        if r2 = [] then rm2 else
-        let row_ext = {row2 with row_fields = r2} in
-        iter_row (moregen_occur env rm1.level) row_ext;
-        newty2 rm1.level (Tvariant row_ext)
-      in
+      let ext = newgenty (Tvariant {row2 with row_fields = r2}) in
+      moregen_occur env rm1.level ext;
       link_type rm1 ext
   | Tconstr _, Tconstr _ ->
       moregen inst_nongen type_pairs env rm1 rm2
@@ -2887,7 +3004,7 @@ let rec get_object_row ty =
 let expand_head_rigid env ty =
   let old = !rigid_variants in
   rigid_variants := true;
-  let ty' = expand_head_unif env ty in
+  let ty' = expand_head env ty in
   rigid_variants := old; ty'
 
 let normalize_subst subst =
@@ -3061,11 +3178,11 @@ let eqtype rename type_pairs subst env t1 t2 =
 type class_match_failure =
     CM_Virtual_class
   | CM_Parameter_arity_mismatch of int * int
-  | CM_Type_parameter_mismatch of (type_expr * type_expr) list
-  | CM_Class_type_mismatch of class_type * class_type
-  | CM_Parameter_mismatch of (type_expr * type_expr) list
-  | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-  | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
   | CM_Non_mutable_value of string
   | CM_Non_concrete_value of string
   | CM_Missing_value of string
@@ -3087,7 +3204,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
         moregen_clty true type_pairs env cty1 cty2
     | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
         begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
-          raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
         end;
         moregen_clty false type_pairs env cty1' cty2'
     | Cty_signature sign1, Cty_signature sign2 ->
@@ -3100,7 +3217,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
           (fun (lab, k1, t1, k2, t2) ->
             begin try moregen true type_pairs env t1 t2 with Unify trace ->
               raise (Failure [CM_Meth_type_mismatch
-                                 (lab, expand_trace env trace)])
+                                 (lab, env, expand_trace env trace)])
            end)
         pairs;
       Vars.iter
@@ -3108,13 +3225,13 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
            let (mut', v', ty') = Vars.find lab sign1.cty_vars in
            try moregen true type_pairs env ty' ty with Unify trace ->
              raise (Failure [CM_Val_type_mismatch
-                                (lab, expand_trace env trace)]))
+                                (lab, env, expand_trace env trace)]))
         sign2.cty_vars
   | _ ->
       raise (Failure [])
   with
     Failure error when trace || error = [] ->
-      raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
 
 let match_class_types ?(trace=true) env pat_sch subj_sch =
   let type_pairs = TypePairs.create 53 in
@@ -3206,7 +3323,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
           Failure r -> r
         end
     | error ->
-        CM_Class_type_mismatch (patt, subj)::error
+        CM_Class_type_mismatch (env, patt, subj)::error
   in
   current_level := old_level;
   res
@@ -3222,7 +3339,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
         equal_clty true type_pairs subst env cty1 cty2
     | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 ->
         begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
-          raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
+          raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])
         end;
         equal_clty false type_pairs subst env cty1' cty2'
     | Cty_signature sign1, Cty_signature sign2 ->
@@ -3236,7 +3353,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
              begin try eqtype true type_pairs subst env t1 t2 with
                Unify trace ->
                  raise (Failure [CM_Meth_type_mismatch
-                                    (lab, expand_trace env trace)])
+                                    (lab, env, expand_trace env trace)])
              end)
           pairs;
         Vars.iter
@@ -3244,15 +3361,15 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
              let (_, _, ty') = Vars.find lab sign1.cty_vars in
              try eqtype true type_pairs subst env ty' ty with Unify trace ->
                raise (Failure [CM_Val_type_mismatch
-                                  (lab, expand_trace env trace)]))
+                                  (lab, env, expand_trace env trace)]))
           sign2.cty_vars
     | _ ->
         raise
           (Failure (if trace then []
-                    else [CM_Class_type_mismatch (cty1, cty2)]))
+                    else [CM_Class_type_mismatch (env, cty1, cty2)]))
   with
     Failure error when trace ->
-      raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error))
+      raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error))
 
 let match_class_declarations env patt_params patt_type subj_params subj_type =
   let type_pairs = TypePairs.create 53 in
@@ -3338,7 +3455,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
         List.iter2 (fun p s ->
           try eqtype true type_pairs subst env p s with Unify trace ->
             raise (Failure [CM_Type_parameter_mismatch
-                               (expand_trace env trace)]))
+                               (env, expand_trace env trace)]))
           patt_params subj_params;
      (* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
         equal_clty false type_pairs subst env
@@ -3489,7 +3606,8 @@ let rec build_subtype env visited loops posi level t =
         then warn := true;
         let tl' =
           List.map2
-            (fun (co,cn,_) t ->
+            (fun v t ->
+              let (co,cn) = Variance.get_upper v in
               if cn then
                 if co then (t, Unchanged)
                 else build_subtype env visited loops (not posi) level t
@@ -3594,12 +3712,6 @@ let subtypes = TypePairs.create 17
 let subtype_error env trace =
   raise (Subtype (expand_trace env (List.rev trace), []))
 
-let private_abbrev env path =
-  try
-    let decl = Env.find_type path env in
-    decl.type_private = Private && decl.type_manifest <> None
-  with Not_found -> false
-
 (* check list inclusion, assuming lists are ordered *)
 let rec included nl1 nl2 =
   match nl1, nl2 with
@@ -3648,7 +3760,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
         begin try
           let decl = Env.find_type p1 env in
           List.fold_left2
-            (fun cstrs (co, cn, _) (t1, t2) ->
+            (fun cstrs v (t1, t2) ->
+              let (co, cn) = Variance.get_upper v in
               if co then
                 if cn then
                   (trace, newty2 t1.level (Ttuple[t1]),
@@ -3661,8 +3774,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
         with Not_found ->
           (trace, t1, t2, !univar_pairs)::cstrs
         end
-    | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
+    | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+(*  | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
+        subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
     | (Tobject (f1, _), Tobject (f2, _))
       when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
         (* Same row variable implies same object. *)
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 560c7ac2..527be9a3 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Operations on core types *)
 
 open Asttypes
@@ -147,6 +145,11 @@ val expand_head_opt: Env.t -> type_expr -> type_expr
 (** The compiler's own version of [expand_head] necessary for type-based
     optimisations. *)
 val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+        Env.t -> type_expr -> Path.t * Path.t * type_declaration
+        (* Return the original path of the types, and the first concrete
+           type declaration found expanding it.
+           Raise [Not_found] if none appears or not a type constructor. *)
 
 val enforce_constraints: Env.t -> type_expr -> unit
 
@@ -183,11 +186,11 @@ val matches: Env.t -> type_expr -> type_expr -> bool
 type class_match_failure =
     CM_Virtual_class
   | CM_Parameter_arity_mismatch of int * int
-  | CM_Type_parameter_mismatch of (type_expr * type_expr) list
-  | CM_Class_type_mismatch of class_type * class_type
-  | CM_Parameter_mismatch of (type_expr * type_expr) list
-  | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-  | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+  | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Class_type_mismatch of Env.t * class_type * class_type
+  | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list
+  | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list
+  | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list
   | CM_Non_mutable_value of string
   | CM_Non_concrete_value of string
   | CM_Missing_value of string
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 71e5a851..8013407e 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -10,18 +10,15 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: datarepr.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Compute constructor and label descriptions from type declarations,
    determining their representation. *)
 
-open Misc
 open Asttypes
 open Types
 open Btype
 
 (* Simplified version of Ctype.free_vars *)
-let rec free_vars ty =
+let free_vars ty =
   let ret = ref TypeSet.empty in
   let rec loop ty =
     let ty = repr ty in
@@ -51,7 +48,7 @@ let constructor_descrs ty_res cstrs priv =
     cstrs;
   let rec describe_constructors idx_const idx_nonconst = function
       [] -> []
-    | (name, ty_args, ty_res_opt) :: rem ->
+    | (id, ty_args, ty_res_opt) :: rem ->
         let ty_res =
           match ty_res_opt with
           | Some ty_res' -> ty_res'
@@ -72,7 +69,8 @@ let constructor_descrs ty_res cstrs priv =
               TypeSet.elements (TypeSet.diff arg_vars res_vars)
         in
         let cstr =
-          { cstr_res = ty_res;
+          { cstr_name = Ident.name id;
+            cstr_res = ty_res;
             cstr_existentials = existentials;
             cstr_args = ty_args;
             cstr_arity = List.length ty_args;
@@ -83,11 +81,12 @@ let constructor_descrs ty_res cstrs priv =
             cstr_private = priv;
             cstr_generalized = ty_res_opt <> None
           } in
-        (name, cstr) :: descr_rem in
+        (id, cstr) :: descr_rem in
   describe_constructors 0 0 cstrs
 
 let exception_descr path_exc decl =
-  { cstr_res = Predef.type_exn;
+  { cstr_name = Path.last path_exc;
+    cstr_res = Predef.type_exn;
     cstr_existentials = [];
     cstr_args = decl.exn_args;
     cstr_arity = List.length decl.exn_args;
@@ -109,9 +108,9 @@ let label_descrs ty_res lbls repres priv =
   let all_labels = Array.create (List.length lbls) dummy_label in
   let rec describe_labels num = function
       [] -> []
-    | (name, mut_flag, ty_arg) :: rest ->
+    | (id, mut_flag, ty_arg) :: rest ->
         let lbl =
-          { lbl_name = Ident.name name;
+          { lbl_name = Ident.name id;
             lbl_res = ty_res;
             lbl_arg = ty_arg;
             lbl_mut = mut_flag;
@@ -120,7 +119,7 @@ let label_descrs ty_res lbls repres priv =
             lbl_repres = repres;
             lbl_private = priv } in
         all_labels.(num) <- lbl;
-        (name, lbl) :: describe_labels (num+1) rest in
+        (id, lbl) :: describe_labels (num+1) rest in
   describe_labels 0 lbls
 
 exception Constr_not_found
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index e5d4428b..30754cb6 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: datarepr.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Compute constructor and label descriptions from type declarations,
    determining their representation. *)
 
diff --git a/typing/env.ml b/typing/env.ml
index 061e86bc..506975f7 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.ml 12820 2012-08-03 20:23:26Z frisch $ *)
-
 (* Environment handling *)
 
 open Cmi_format
@@ -53,8 +51,10 @@ let used_constructors :
     (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t
   = Hashtbl.create 16
 
+let prefixed_sg = Hashtbl.create 113
+
 type error =
-  | Illegal_renaming of string * string
+  | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
 
@@ -65,6 +65,7 @@ module EnvLazy : sig
 
   val force : ('a -> 'b) -> ('a,'b) t -> 'b
   val create : 'a -> ('a,'b) t
+  val is_val : ('a,'b) t -> bool
 
 end  = struct
 
@@ -88,6 +89,9 @@ end  = struct
             x := Raise e;
             raise e
 
+  let is_val x =
+    match !x with Done _ -> true | _ -> false
+
   let create x =
     let x = ref (Thunk x) in
     x
@@ -109,45 +113,58 @@ type summary =
 module EnvTbl =
   struct
     (* A table indexed by identifier, with an extra slot to record usage. *)
-    type 'a t = ('a * bool ref) Ident.tbl
+    type 'a t = ('a * (unit -> unit)) Ident.tbl
 
     let empty = Ident.empty
-    let current_slot = ref (ref true)
+    let nothing = fun () -> ()
+
+    let already_defined s tbl =
+      try ignore (Ident.find_name s tbl); true
+      with Not_found -> false
+
+    let add kind slot id x tbl ref_tbl =
+      let slot =
+        match slot with
+        | None -> nothing
+        | Some f ->
+          (fun () ->
+             let s = Ident.name id in
+             f kind s (already_defined s ref_tbl)
+          )
+      in
+      Ident.add id (x, slot) tbl
 
-    let add id x tbl =
-      Ident.add id (x, !current_slot) tbl
+    let add_dont_track id x tbl =
+      Ident.add id (x, nothing) tbl
 
     let find_same_not_using id tbl =
       fst (Ident.find_same id tbl)
 
     let find_same id tbl =
       let (x, slot) = Ident.find_same id tbl in
-      slot := true;
+      slot ();
       x
 
     let find_name s tbl =
       let (x, slot) = Ident.find_name s tbl in
-      slot := true;
+      slot ();
       x
 
-    let with_slot slot f x =
-      let old_slot = !current_slot in
-      current_slot := slot;
-      try_finally
-        (fun () -> f x)
-        (fun () -> current_slot := old_slot)
+    let find_all s tbl =
+      Ident.find_all s tbl
 
-    let keys tbl =
-      Ident.keys 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 =
+    constructor_description list * label_description list
+
 type t = {
   values: (Path.t * value_description) EnvTbl.t;
-  annotations: (Path.t * Annot.ident) EnvTbl.t;
-  constrs: (Path.t * constructor_description) EnvTbl.t;
-  labels: (Path.t * label_description) EnvTbl.t;
-  constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
-  types: (Path.t * type_declaration) 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_type) EnvTbl.t;
   modtypes: (Path.t * modtype_declaration) EnvTbl.t;
   components: (Path.t * module_components) EnvTbl.t;
@@ -168,12 +185,10 @@ and module_components_repr =
 
 and structure_components = {
   mutable comp_values: (string, (value_description * int)) Tbl.t;
-  mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
-  mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
-  mutable comp_labels: (string, (label_description * int)) Tbl.t;
-  mutable comp_constrs_by_path:
-      (string, (constructor_description list * int)) Tbl.t;
-  mutable comp_types: (string, (type_declaration * 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_modules:
    (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t;
   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
@@ -194,9 +209,8 @@ and functor_components = {
 let subst_modtype_maker (subst, mty) = Subst.modtype subst mty
 
 let empty = {
-  values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty;
+  values = EnvTbl.empty; constrs = EnvTbl.empty;
   labels = EnvTbl.empty; types = EnvTbl.empty;
-  constrs_by_path = EnvTbl.empty;
   modules = EnvTbl.empty; modtypes = EnvTbl.empty;
   components = EnvTbl.empty; classes = EnvTbl.empty;
   cltypes = EnvTbl.empty;
@@ -221,9 +235,13 @@ let is_ident = function
 
 let is_local (p, _) = is_ident p
 
+let is_local_exn = function
+  | {cstr_tag = Cstr_exception (p, _)} -> is_ident p
+  | _ -> false
+
 let diff env1 env2 =
   diff_keys is_local env1.values env2.values @
-  diff_keys is_local env1.constrs env2.constrs @
+  diff_keys is_local_exn env1.constrs env2.constrs @
   diff_keys is_local env1.modules env2.modules @
   diff_keys is_local env1.classes env2.classes
 
@@ -275,7 +293,7 @@ let check_consistency filename crcs =
 
 (* Reading persistent structures from .cmi files *)
 
-let read_pers_struct modname filename =
+let read_pers_struct modname filename = (
   let cmi = read_cmi filename in
   let name = cmi.cmi_name in
   let sign = cmi.cmi_sign in
@@ -292,7 +310,7 @@ let read_pers_struct modname filename =
                ps_filename = filename;
                ps_flags = flags } in
     if ps.ps_name <> modname then
-      raise(Error(Illegal_renaming(ps.ps_name, filename)));
+      raise(Error(Illegal_renaming(modname, ps.ps_name, filename)));
     check_consistency filename ps.ps_crcs;
     List.iter
       (function Rectypes ->
@@ -301,6 +319,7 @@ let read_pers_struct modname filename =
       ps.ps_flags;
     Hashtbl.add persistent_structures modname (Some ps);
     ps
+)
 
 let find_pers_struct name =
   if name = "*predef*" then raise Not_found;
@@ -325,13 +344,23 @@ let reset_cache () =
   Hashtbl.clear persistent_structures;
   Consistbl.clear crc_units;
   Hashtbl.clear value_declarations;
-  Hashtbl.clear type_declarations
-
-let reset_missing_cmis () =
-  let l = Hashtbl.fold
+  Hashtbl.clear type_declarations;
+  Hashtbl.clear used_constructors;
+  Hashtbl.clear prefixed_sg
+
+let reset_cache_toplevel () =
+  (* Delete 'missing cmi' entries from the cache. *)
+  let l =
+    Hashtbl.fold
       (fun name r acc -> if r = None then name :: acc else acc)
-      persistent_structures [] in
-  List.iter (Hashtbl.remove persistent_structures) l
+      persistent_structures []
+  in
+  List.iter (Hashtbl.remove persistent_structures) l;
+  Hashtbl.clear value_declarations;
+  Hashtbl.clear type_declarations;
+  Hashtbl.clear used_constructors;
+  Hashtbl.clear prefixed_sg
+
 
 let set_unit_name name =
   current_unit := name
@@ -388,12 +417,8 @@ let find proj1 proj2 path env =
 
 let find_value =
   find (fun env -> env.values) (fun sc -> sc.comp_values)
-and find_annot =
-  find (fun env -> env.annotations) (fun sc -> sc.comp_annotations)
-and find_type =
+and find_type_full =
   find (fun env -> env.types) (fun sc -> sc.comp_types)
-and find_constructors =
-  find (fun env -> env.constrs_by_path) (fun sc -> sc.comp_constrs_by_path)
 and find_modtype =
   find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
 and find_class =
@@ -401,6 +426,11 @@ and find_class =
 and find_cltype =
   find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
+let find_type p env =
+  fst (find_type_full p env)
+let find_type_descrs p env =
+  snd (find_type_full p env)
+
 (* Find the manifest type associated to a type when appropriate:
    - the type should be public or should have a private row,
    - the type should have an associated manifest type. *)
@@ -461,6 +491,8 @@ let find_module path env =
 
 (* Lookup by name *)
 
+exception Recmodule
+
 let rec lookup_module_descr lid env =
   match lid with
     Lident s ->
@@ -495,7 +527,14 @@ and lookup_module lid env =
   match lid with
     Lident s ->
       begin try
-        EnvTbl.find_name s env.modules
+        let (_, ty) as r = EnvTbl.find_name s env.modules in
+        begin match ty with
+        | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
+          (* see #5965 *)
+          raise Recmodule
+        | _ -> ()
+        end;
+        r
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -555,16 +594,51 @@ let lookup_simple proj1 proj2 lid env =
   | Lapply(l1, l2) ->
       raise Not_found
 
+let lookup_all_simple proj1 proj2 shadow lid env =
+  match lid with
+    Lident s ->
+      let xl = EnvTbl.find_all s (proj1 env) in
+      let rec do_shadow =
+        function
+        | [] -> []
+        | ((x, f) :: xs) ->
+            (x, f) ::
+              (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+      in
+        do_shadow xl
+  | Ldot(l, s) ->
+      let (p, desc) = lookup_module_descr l env in
+      begin match EnvLazy.force !components_of_module_maker' desc with
+        Structure_comps c ->
+          let comps =
+            try Tbl.find s (proj2 c) with Not_found -> []
+          in
+          List.map
+            (fun (data, pos) -> (data, (fun () -> ())))
+            comps
+      | Functor_comps f ->
+          raise Not_found
+      end
+  | Lapply(l1, l2) ->
+      raise Not_found
+
 let has_local_constraints env = env.local_constraints
 
+let cstr_shadow cstr1 cstr2 =
+  match cstr1.cstr_tag, cstr2.cstr_tag with
+    Cstr_exception _, Cstr_exception _ -> true
+  | _ -> false
+
+let lbl_shadow lbl1 lbl2 = false
+
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-let lookup_annot id e =
-  lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
-and lookup_constructor =
-  lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
-  lookup (fun env -> env.labels) (fun sc -> sc.comp_labels)
+and lookup_all_constructors =
+  lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+    cstr_shadow
+and lookup_all_labels =
+  lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+    lbl_shadow
 and lookup_type =
   lookup (fun env -> env.types) (fun sc -> sc.comp_types)
 and lookup_modtype =
@@ -603,10 +677,14 @@ let set_value_used_callback name vd callback =
     Hashtbl.add value_declarations key callback
 
 let set_type_used_callback name td callback =
+  let loc = td.type_loc in
+  if loc.Location.loc_ghost then ()
+  else let key = (name, loc) in
   let old =
-    try Hashtbl.find type_declarations (name, td.type_loc)
-    with Not_found -> assert false in
-  Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old)
+    try Hashtbl.find type_declarations key
+    with Not_found -> assert false
+  in
+  Hashtbl.replace type_declarations key (fun () -> callback old)
 
 let lookup_value lid env =
   let (_, desc) as r = lookup_value lid env in
@@ -614,29 +692,50 @@ let lookup_value lid env =
   r
 
 let lookup_type lid env =
-  let (_, desc) as r = lookup_type lid env in
-  mark_type_used (Longident.last lid) desc;
-  r
+  let (path, (decl, _)) = lookup_type lid env in
+  mark_type_used (Longident.last lid) decl;
+  (path, decl)
 
 (* [path] must be the path to a type, not to a module ! *)
-let rec path_subst_last path id =
+let path_subst_last path id =
   match path with
     Pident _ -> Pident id
   | Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos)
   | Papply (p1, p2) -> assert false
 
 let mark_type_path env path =
-  let decl = try find_type path env with Not_found -> assert false in
-  mark_type_used (Path.last path) decl
+  try
+    let decl = find_type path env in
+    mark_type_used (Path.last path) decl
+  with Not_found -> ()
 
-let ty_path = function
+let ty_path t =
+  match repr t with
   | {desc=Tconstr(path, _, _)} -> path
   | _ -> assert false
 
 let lookup_constructor lid env =
-  let (_,desc) as c = lookup_constructor lid env in
-  mark_type_path env (ty_path desc.cstr_res);
-  c
+  match lookup_all_constructors lid env with
+    [] -> raise Not_found
+  | (desc, use) :: _ ->
+      mark_type_path env (ty_path desc.cstr_res);
+      use ();
+      desc
+
+let is_lident = function
+    Lident _ -> true
+  | _ -> false
+
+let lookup_all_constructors lid env =
+  try
+    let cstrs = lookup_all_constructors lid env in
+    let wrap_use desc use () =
+      mark_type_path env (ty_path desc.cstr_res);
+      use ()
+    in
+    List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
+  with
+    Not_found when is_lident lid -> []
 
 let mark_constructor usage env name desc =
   match desc.cstr_tag with
@@ -652,9 +751,23 @@ let mark_constructor usage env name desc =
       mark_constructor_used usage ty_name ty_decl name
 
 let lookup_label lid env =
-  let (_,desc) as c = lookup_label lid env in
-  mark_type_path env (ty_path desc.lbl_res);
-  c
+  match lookup_all_labels lid env with
+    [] -> raise Not_found
+  | (desc, use) :: _ ->
+      mark_type_path env (ty_path desc.lbl_res);
+      use ();
+      desc
+
+let lookup_all_labels lid env =
+  try
+    let lbls = lookup_all_labels lid env in
+    let wrap_use desc use () =
+      mark_type_path env (ty_path desc.lbl_res);
+      use ()
+    in
+    List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
+  with
+    Not_found when is_lident lid -> []
 
 let lookup_class lid env =
   let (_, desc) as r = lookup_class lid env in
@@ -670,6 +783,82 @@ let lookup_cltype lid env =
   mark_type_path env desc.clty_path;
   r
 
+(* Iter on an environment (ignoring the body of functors and
+   not yet evaluated structures) *)
+
+let iter_env proj1 proj2 f env =
+  Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
+  let rec iter_components path path' mcomps =
+    (* if EnvLazy.is_val mcomps then *)
+    match EnvLazy.force !components_of_module_maker' mcomps with
+      Structure_comps comps ->
+        Tbl.iter
+          (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d))
+          (proj2 comps);
+        Tbl.iter
+          (fun s (c, n) ->
+            iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c)
+          comps.comp_components
+    | Functor_comps _ -> ()
+  in
+  Hashtbl.iter
+    (fun s pso ->
+      match pso with None -> ()
+      | Some ps ->
+          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)
+    env.components
+
+let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f
+
+let same_types env1 env2 =
+  env1.types == env2.types && env1.components == env2.components
+
+let used_persistent () =
+  let r = ref Concr.empty in
+  Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r)
+    persistent_structures;
+  !r
+
+let find_all_comps proj s (p,mcomps) =
+  match EnvLazy.force !components_of_module_maker' mcomps with
+    Functor_comps _ -> []
+  | Structure_comps comps ->
+      try let (c,n) = Tbl.find 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)
+  | Pdot (p, s, _) ->
+      let l = find_shadowed_comps p env in
+      let l' =
+        List.map (find_all_comps (fun comps -> comps.comp_components) s) l in
+      List.flatten l'
+  | Papply _ -> []
+
+let find_shadowed proj1 proj2 path env =
+  match path with
+    Pident id ->
+      List.map fst (Ident.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
+      List.flatten l'
+  | 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
+
+
 (* GADT instance tracking *)
 
 let add_gadt_instance_level lv env =
@@ -788,8 +977,58 @@ let rec prefix_idents root pos sub = function
       let (pl, final_sub) = prefix_idents root pos 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_exception(id, decl) ->
+          Sig_exception (id, Subst.exception_declaration sub decl)
+      | Sig_module(id, mty, x) ->
+          Sig_module(id, Subst.modtype 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 =
+  if sub = Subst.identity then
+    let sgs =
+      try
+        Hashtbl.find prefixed_sg root
+      with Not_found ->
+        let sgs = ref [] in
+        Hashtbl.add prefixed_sg root sgs;
+        sgs
+    in
+    try
+      List.assq sg !sgs
+    with Not_found ->
+      let r = prefix_idents_and_subst root sub sg in
+      sgs := (sg, r) :: !sgs;
+      r
+  else
+    prefix_idents_and_subst root sub sg
+
 (* Compute structure descriptions *)
 
+let add_to_tbl id decl tbl =
+  let decls =
+    try Tbl.find id tbl with Not_found -> [] in
+  Tbl.add id (decl :: decls) tbl
+
 let rec components_of_module env sub path mty =
   EnvLazy.create (env, sub, path, mty)
 
@@ -797,14 +1036,13 @@ and components_of_module_maker (env, sub, path, mty) =
   (match scrape_modtype mty env with
     Mty_signature sg ->
       let c =
-        { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+        { comp_values = Tbl.empty;
           comp_constrs = Tbl.empty;
           comp_labels = Tbl.empty; comp_types = Tbl.empty;
-          comp_constrs_by_path = Tbl.empty;
           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 path 0 sub sg in
+      let pl, sub, _ = prefix_idents_and_subst path sub sg in
       let env = ref env in
       let pos = ref 0 in
       List.iter2 (fun item path ->
@@ -813,39 +1051,34 @@ and components_of_module_maker (env, sub, path, mty) =
             let decl' = Subst.value_description sub decl in
             c.comp_values <-
               Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
-            if !Clflags.annotations then begin
-              c.comp_annotations <-
-                Tbl.add (Ident.name id) (Annot.Iref_external, !pos)
-                        c.comp_annotations;
-            end;
             begin match decl.val_kind with
               Val_prim _ -> () | _ -> incr pos
             end
         | Sig_type(id, decl, _) ->
             let decl' = Subst.type_declaration sub decl in
+            let constructors = List.map snd (constructors_of_type path decl') in
+            let labels = List.map snd (labels_of_type path decl') in
             c.comp_types <-
-              Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
-            let constructors = constructors_of_type path decl' in
-            c.comp_constrs_by_path <-
               Tbl.add (Ident.name id)
-                (List.map snd constructors, nopos) c.comp_constrs_by_path;
+                ((decl', (constructors, labels)), nopos)
+                  c.comp_types;
             List.iter
-              (fun (name, descr) ->
+              (fun descr ->
                 c.comp_constrs <-
-                  Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs)
+                  add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
               constructors;
-            let labels = labels_of_type path decl' in
             List.iter
-              (fun (name, descr) ->
+              (fun descr ->
                 c.comp_labels <-
-                  Tbl.add (Ident.name name) (descr, nopos) c.comp_labels)
-              (labels);
-            env := store_type_infos id path decl !env
+                  add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
+              labels;
+            env := store_type_infos None id path decl !env !env
         | Sig_exception(id, decl) ->
             let decl' = Subst.exception_declaration sub decl in
             let cstr = Datarepr.exception_descr path decl' in
+            let s = Ident.name id in
             c.comp_constrs <-
-              Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
+              add_to_tbl s (cstr, !pos) c.comp_constrs;
             incr pos
         | Sig_module(id, mty, _) ->
             let mty' = EnvLazy.create (sub, mty) in
@@ -854,13 +1087,13 @@ and components_of_module_maker (env, sub, path, mty) =
             let comps = components_of_module !env sub path mty in
             c.comp_components <-
               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module id path mty !env;
+            env := store_module None id path mty !env !env;
             incr pos
         | Sig_modtype(id, decl) ->
             let decl' = Subst.modtype_declaration sub decl in
             c.comp_modtypes <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
-            env := store_modtype id path decl !env
+            env := store_modtype None id path decl !env !env
         | Sig_class(id, decl, _) ->
             let decl' = Subst.class_declaration sub decl in
             c.comp_classes <-
@@ -885,10 +1118,10 @@ and components_of_module_maker (env, sub, path, mty) =
           fcomp_cache = Hashtbl.create 17 }
   | Mty_ident p ->
         Structure_comps {
-          comp_values = Tbl.empty; comp_annotations = Tbl.empty;
+          comp_values = Tbl.empty;
           comp_constrs = Tbl.empty;
           comp_labels = Tbl.empty;
-          comp_types = Tbl.empty; comp_constrs_by_path = 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 })
@@ -908,32 +1141,26 @@ and check_usage loc id warn tbl =
         (fun () -> if not !used then Location.prerr_warning loc (warn name))
   end;
 
-and store_value ?check id path decl env =
+and store_value ?check slot id path decl env renv =
   may (fun f -> check_usage decl.val_loc id f value_declarations) check;
   { env with
-    values = EnvTbl.add id (path, decl) env.values;
+    values = EnvTbl.add "value" slot id (path, decl) env.values renv.values;
     summary = Env_value(env.summary, id, decl) }
 
-and store_annot id path annot env =
-  if !Clflags.annotations then
-    { env with
-      annotations = EnvTbl.add id (path, annot) env.annotations }
-  else env
-
-and store_type id path info env =
+and store_type slot id path info env renv =
   let loc = info.type_loc in
   check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
     type_declarations;
   let constructors = constructors_of_type path info in
   let labels = labels_of_type path info in
+  let descrs = (List.map snd constructors, List.map snd labels) in
 
   if not loc.Location.loc_ghost &&
     Warnings.is_active (Warnings.Unused_constructor ("", false, false))
   then begin
     let ty = Ident.name id in
     List.iter
-      begin fun (c, _) ->
-        let c = Ident.name c in
+      begin fun (_, {cstr_name = c; _}) ->
         let k = (ty, loc, c) in
         if not (Hashtbl.mem used_constructors k) then
           let used = constructor_usages () in
@@ -951,34 +1178,32 @@ and store_type id path info env =
   { env with
     constrs =
       List.fold_right
-        (fun (name, descr) constrs ->
-          EnvTbl.add name (path_subst_last path name, descr) constrs)
+        (fun (id, descr) constrs ->
+          EnvTbl.add "constructor" slot id descr constrs renv.constrs)
         constructors
         env.constrs;
-
-    constrs_by_path =
-      EnvTbl.add id
-        (path,List.map snd constructors) env.constrs_by_path;
     labels =
       List.fold_right
-        (fun (name, descr) labels ->
-          EnvTbl.add name (path_subst_last path name, descr) labels)
+        (fun (id, descr) labels ->
+          EnvTbl.add "label" slot id descr labels renv.labels)
         labels
         env.labels;
-    types = EnvTbl.add id (path, info) env.types;
+    types = EnvTbl.add "type" slot id (path, (info, descrs)) env.types
+                       renv.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_type_infos id path info env =
+and store_type_infos slot id path info env renv =
   (* 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 id (path, info) env.types;
+    types = EnvTbl.add "type" slot id (path, (info,([],[]))) env.types
+                       renv.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_exception id path decl env =
+and store_exception slot id path decl env renv =
   let loc = decl.exn_loc in
   if not loc.Location.loc_ghost &&
     Warnings.is_active (Warnings.Unused_exception ("", false))
@@ -1000,31 +1225,35 @@ and store_exception id path decl env =
     end;
   end;
   { env with
-    constrs = EnvTbl.add id (path_subst_last path id,
-                             Datarepr.exception_descr path decl) env.constrs;
+    constrs = EnvTbl.add "constructor" slot id
+                         (Datarepr.exception_descr path decl) env.constrs
+                         renv.constrs;
     summary = Env_exception(env.summary, id, decl) }
 
-and store_module id path mty env =
+and store_module slot id path mty env renv =
   { env with
-    modules = EnvTbl.add id (path, mty) env.modules;
+    modules = EnvTbl.add "module" slot id (path, mty) env.modules renv.modules;
     components =
-      EnvTbl.add id (path, components_of_module env Subst.identity path mty)
-                   env.components;
+      EnvTbl.add "module" slot id
+                 (path, components_of_module env Subst.identity path mty)
+                   env.components renv.components;
     summary = Env_module(env.summary, id, mty) }
 
-and store_modtype id path info env =
+and store_modtype slot id path info env renv =
   { env with
-    modtypes = EnvTbl.add id (path, info) env.modtypes;
+    modtypes = EnvTbl.add "module type" slot id (path, info) env.modtypes
+                          renv.modtypes;
     summary = Env_modtype(env.summary, id, info) }
 
-and store_class id path desc env =
+and store_class slot id path desc env renv =
   { env with
-    classes = EnvTbl.add id (path, desc) env.classes;
+    classes = EnvTbl.add "class" slot id (path, desc) env.classes renv.classes;
     summary = Env_class(env.summary, id, desc) }
 
-and store_cltype id path desc env =
+and store_cltype slot id path desc env renv =
   { env with
-    cltypes = EnvTbl.add id (path, desc) env.cltypes;
+    cltypes = EnvTbl.add "class type" slot id (path, desc) env.cltypes
+                         renv.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
 (* Compute the components of a functor application in a path. *)
@@ -1051,28 +1280,25 @@ let _ =
 (* Insertion of bindings by identifier *)
 
 let add_value ?check id desc env =
-  store_value ?check id (Pident id) desc env
+  store_value None ?check id (Pident id) desc env env
 
-let add_annot id annot env =
-  store_annot id (Pident id) annot env
-
-and add_type id info env =
-  store_type id (Pident id) info env
+let add_type id info env =
+  store_type None id (Pident id) info env env
 
 and add_exception id decl env =
-  store_exception id (Pident id) decl env
+  store_exception None id (Pident id) decl env env
 
 and add_module id mty env =
-  store_module id (Pident id) mty env
+  store_module None id (Pident id) mty env env
 
 and add_modtype id info env =
-  store_modtype id (Pident id) info env
+  store_modtype None id (Pident id) info env env
 
 and add_class id ty env =
-  store_class id (Pident id) ty env
+  store_class None id (Pident id) ty env env
 
 and add_cltype id ty env =
-  store_cltype id (Pident id) ty env
+  store_cltype None id (Pident id) ty env env
 
 let add_local_constraint id info elv env =
   match info with
@@ -1086,7 +1312,7 @@ let add_local_constraint id info elv env =
 (* Insertion of bindings by name *)
 
 let enter store_fun name data env =
-  let id = Ident.create name in (id, store_fun id (Pident id) data env)
+  let id = Ident.create name in (id, store_fun None id (Pident id) data env env)
 
 let enter_value ?check = enter (store_value ?check)
 and enter_type = enter store_type
@@ -1115,46 +1341,46 @@ let rec add_signature sg env =
 
 (* Open a signature path *)
 
-let open_signature root sg env =
+let open_signature slot root sg env0 =
   (* First build the paths and substitution *)
-  let (pl, sub) = prefix_idents root 0 Subst.identity sg in
+  let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+  let sg = Lazy.force sg in
+
   (* Then enter the components in the environment after substitution *)
+
   let newenv =
     List.fold_left2
       (fun env item p ->
         match item with
           Sig_value(id, decl) ->
-            let e1 = store_value (Ident.hide id) p
-                        (Subst.value_description sub decl) env
-            in store_annot (Ident.hide id) p (Annot.Iref_external) e1
+            store_value slot (Ident.hide id) p decl env env0
         | Sig_type(id, decl, _) ->
-            store_type (Ident.hide id) p
-                       (Subst.type_declaration sub decl) env
+            store_type slot (Ident.hide id) p decl env env0
         | Sig_exception(id, decl) ->
-            store_exception (Ident.hide id) p
-                            (Subst.exception_declaration sub decl) env
+            store_exception slot (Ident.hide id) p decl env env0
         | Sig_module(id, mty, _) ->
-            store_module (Ident.hide id) p (Subst.modtype sub mty) env
+            store_module slot (Ident.hide id) p mty env env0
         | Sig_modtype(id, decl) ->
-            store_modtype (Ident.hide id) p
-                          (Subst.modtype_declaration sub decl) env
+            store_modtype slot (Ident.hide id) p decl env env0
         | Sig_class(id, decl, _) ->
-            store_class (Ident.hide id) p
-                        (Subst.class_declaration sub decl) env
+            store_class slot (Ident.hide id) p decl env env0
         | Sig_class_type(id, decl, _) ->
-            store_cltype (Ident.hide id) p
-                         (Subst.cltype_declaration sub decl) env)
-      env sg pl in
-  { newenv with summary = Env_open(env.summary, root) }
+            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 (Pident(Ident.create_persistent name)) ps.ps_sig env
+  open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env
 
-let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env =
-  if not toplevel && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "")
+let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg 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
     !add_delayed_check_forward
@@ -1162,9 +1388,23 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env =
         if not !used then
           Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
       );
-    EnvTbl.with_slot used (open_signature root sg) env
+    let shadowed = ref [] in
+    let slot kind s b =
+      if b && not (List.mem (kind, s) !shadowed) then begin
+        shadowed := (kind, s) :: !shadowed;
+        let w =
+          match kind with
+          | "label" | "constructor" ->
+              Warnings.Open_shadow_label_constructor (kind, s)
+          | _ -> Warnings.Open_shadow_identifier (kind, s)
+        in
+        Location.prerr_warning loc w
+      end;
+      used := true
+    in
+    open_signature (Some slot) root sg env
   end
-  else open_signature root sg env
+  else open_signature None root sg env
 
 (* Read a signature from a file *)
 
@@ -1225,16 +1465,11 @@ let save_signature sg modname filename =
   save_signature_with_imports sg modname filename (imported_units())
 
 (* Folding on environments *)
-let ident_tbl_fold f t acc =
-  List.fold_right
-    (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc)
-    (EnvTbl.keys t)
-    acc
 
 let find_all proj1 proj2 f lid env acc =
   match lid with
     | None ->
-      ident_tbl_fold
+      EnvTbl.fold_name
         (fun id (p, data) acc -> f (Ident.name id) p data acc)
         (proj1 env) acc
     | Some l ->
@@ -1245,14 +1480,35 @@ let find_all proj1 proj2 f lid env acc =
               (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc)
               (proj2 c) acc
         | Functor_comps _ ->
-          raise Not_found
+            acc
+      end
+
+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)
+        (proj1 env) acc
+    | Some l ->
+      let p, desc = lookup_module_descr l env in
+      begin match EnvLazy.force components_of_module_maker desc with
+          Structure_comps c ->
+            Tbl.fold
+              (fun s comps acc ->
+                match comps with
+                  [] -> acc
+                | (data, pos) :: _ ->
+                  f data acc)
+              (proj2 c) acc
+        | Functor_comps _ ->
+            acc
       end
 
 let fold_modules f lid env acc =
   match lid with
     | None ->
       let acc =
-        ident_tbl_fold
+        EnvTbl.fold_name
           (fun id (p, data) acc -> f (Ident.name id) p data acc)
           env.modules
           acc
@@ -1277,15 +1533,15 @@ let fold_modules f lid env acc =
               c.comp_modules
               acc
         | Functor_comps _ ->
-          raise Not_found
+            acc
       end
 
 let fold_values f =
   find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
 and fold_constructors f =
-  find_all (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+  find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
 and fold_labels f =
-  find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+  find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
 and fold_types f =
   find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
 and fold_modtypes f =
@@ -1303,12 +1559,26 @@ let initial = Predef.build_initial_env add_type add_exception empty
 (* Return the environment summary *)
 
 let summary env = env.summary
+
+let last_env = ref empty
+let last_reduced_env = ref empty
+
 let keep_only_summary env =
-  { empty with
-    summary = env.summary;
-    local_constraints = env.local_constraints;
-    in_signature = env.in_signature;
-}
+  if !last_env == env then !last_reduced_env
+  else begin
+    let new_env =
+      {
+       empty with
+       summary = env.summary;
+       local_constraints = env.local_constraints;
+       in_signature = env.in_signature;
+      }
+    in
+    last_env := env;
+    last_reduced_env := new_env;
+    new_env
+  end
+
 
 let env_of_only_summary env_from_summary env =
   let new_env = env_from_summary env.summary Subst.identity in
@@ -1322,9 +1592,9 @@ let env_of_only_summary env_from_summary env =
 open Format
 
 let report_error ppf = function
-  | Illegal_renaming(modname, filename) -> fprintf ppf
-      "Wrong file naming: %a@ contains the compiled interface for@ %s"
-      Location.print_filename filename modname
+  | Illegal_renaming(name, modname, filename) -> fprintf ppf
+      "Wrong file naming: %a@ contains the compiled interface for @ %s when %s was expected"
+      Location.print_filename filename name modname
   | Inconsistent_import(name, source1, source2) -> fprintf ppf
       "@[The files %a@ and %a@ \
               make inconsistent assumptions@ over interface %s@]"
diff --git a/typing/env.mli b/typing/env.mli
index 9846dc46..38d8ceea 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Environment handling *)
 
 open Types
@@ -33,12 +31,22 @@ val empty: t
 val initial: t
 val diff: t -> t -> Ident.t list
 
+type type_descriptions =
+    constructor_description list * label_description list
+
+(* For short-paths *)
+val iter_types:
+    (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) ->
+    t -> unit
+val same_types: t -> t -> bool
+val used_persistent: unit -> Concr.t
+val find_shadowed_types: Path.t -> t -> Path.t list
+
 (* Lookup by paths *)
 
 val find_value: Path.t -> t -> value_description
-val find_annot: Path.t -> t -> Annot.ident
 val find_type: Path.t -> t -> type_declaration
-val find_constructors: Path.t -> t -> constructor_description list
+val find_type_descrs: Path.t -> t -> type_descriptions
 val find_module: Path.t -> t -> module_type
 val find_modtype: Path.t -> t -> modtype_declaration
 val find_class: Path.t -> t -> class_declaration
@@ -50,7 +58,7 @@ val find_type_expansion_opt:
     Path.t -> t -> type_expr list * type_expr * int option
 (* Find the manifest type information associated to a type for the sake
    of the compiler's type-based optimisations. *)
-val find_modtype_expansion: Path.t -> t -> Types.module_type
+val find_modtype_expansion: Path.t -> t -> module_type
 
 val has_local_constraints: t -> bool
 val add_gadt_instance_level: int -> t -> t
@@ -61,20 +69,27 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit
 (* Lookup by long identifiers *)
 
 val lookup_value: Longident.t -> t -> Path.t * value_description
-val lookup_annot: Longident.t -> t -> Path.t * Annot.ident
-val lookup_constructor: Longident.t -> t -> Path.t * constructor_description
-val lookup_label: Longident.t -> t -> Path.t * label_description
+val lookup_constructor: Longident.t -> t -> constructor_description
+val lookup_all_constructors:
+  Longident.t -> t -> (constructor_description * (unit -> unit)) list
+val lookup_label: Longident.t -> t -> label_description
+val lookup_all_labels:
+  Longident.t -> t -> (label_description * (unit -> unit)) list
 val lookup_type: Longident.t -> t -> Path.t * type_declaration
 val lookup_module: Longident.t -> t -> Path.t * module_type
 val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
 val lookup_class: Longident.t -> t -> Path.t * class_declaration
 val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration
 
+exception Recmodule
+  (* Raise by lookup_module when the identifier refers
+     to one of the modules of a recursive definition
+     during the computation of its approximation (see #5965). *)
+
 (* Insertion by identifier *)
 
 val add_value:
     ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
-val add_annot: Ident.t -> Annot.ident -> t -> t
 val add_type: Ident.t -> type_declaration -> t -> t
 val add_exception: Ident.t -> exception_declaration -> t -> t
 val add_module: Ident.t -> module_type -> t -> t
@@ -91,7 +106,9 @@ val add_signature: signature -> t -> t
 (* Insertion of all fields of a signature, relative to the given path.
    Used to implement open. *)
 
-val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t
+val open_signature:
+    ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
+      signature -> t -> t
 val open_pers_signature: string -> t -> t
 
 (* Insertion by name *)
@@ -108,7 +125,9 @@ val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t
 
 (* Initialize the cache of in-core module interfaces. *)
 val reset_cache: unit -> unit
-val reset_missing_cmis: unit -> unit
+
+(* To be called before each toplevel phrase. *)
+val reset_cache_toplevel: unit -> unit
 
 (* Remember the name of the current compilation unit. *)
 val set_unit_name: string -> unit
@@ -148,11 +167,10 @@ val summary: t -> summary
 val keep_only_summary : t -> t
 val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
 
-
 (* Error report *)
 
 type error =
-  | Illegal_renaming of string * string
+  | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
 
@@ -190,29 +208,29 @@ val add_delayed_check_forward: ((unit -> unit) -> unit) ref
 (** Folding over all identifiers (for analysis purpose) *)
 
 val fold_values:
-  (string -> Path.t -> Types.value_description -> 'a -> 'a) ->
+  (string -> Path.t -> value_description -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 val fold_types:
-  (string -> Path.t -> Types.type_declaration -> 'a -> 'a) ->
+  (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 val fold_constructors:
-  (string -> Path.t -> Types.constructor_description -> 'a -> 'a) ->
+  (constructor_description -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 val fold_labels:
-  (string -> Path.t -> Types.label_description -> 'a -> 'a) ->
+  (label_description -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 
 (** Persistent structures are only traversed if they are already loaded. *)
 val fold_modules:
-  (string -> Path.t -> Types.module_type -> 'a -> 'a) ->
+  (string -> Path.t -> module_type -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 
 val fold_modtypes:
-  (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) ->
+  (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 val fold_classs:
-  (string -> Path.t -> Types.class_declaration -> 'a -> 'a) ->
+  (string -> Path.t -> class_declaration -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
 val fold_cltypes:
-  (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) ->
+  (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
   Longident.t option -> t -> 'a -> 'a
diff --git a/typing/envaux.ml b/typing/envaux.ml
new file mode 100644
index 00000000..5e8b524e
--- /dev/null
+++ b/typing/envaux.ml
@@ -0,0 +1,87 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Misc
+open Types
+open Env
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+let env_cache =
+  (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
+
+let reset_cache () =
+  Hashtbl.clear env_cache;
+  Env.reset_cache()
+
+let extract_sig env mty =
+  match Mtype.scrape 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)
+  with Not_found ->
+    let env =
+      match sum with
+        Env_empty ->
+          Env.empty
+      | Env_value(s, id, desc) ->
+          Env.add_value id (Subst.value_description subst desc)
+                        (env_from_summary s subst)
+      | Env_type(s, id, desc) ->
+          Env.add_type id (Subst.type_declaration subst desc)
+                       (env_from_summary s subst)
+      | Env_exception(s, id, desc) ->
+          Env.add_exception id (Subst.exception_declaration subst desc)
+                            (env_from_summary s subst)
+      | Env_module(s, id, desc) ->
+          Env.add_module id (Subst.modtype subst desc)
+                         (env_from_summary s subst)
+      | Env_modtype(s, id, desc) ->
+          Env.add_modtype id (Subst.modtype_declaration subst desc)
+                          (env_from_summary s subst)
+      | Env_class(s, id, desc) ->
+          Env.add_class id (Subst.class_declaration subst desc)
+                        (env_from_summary s subst)
+      | Env_cltype (s, id, desc) ->
+          Env.add_cltype id (Subst.cltype_declaration subst desc)
+                         (env_from_summary s subst)
+      | Env_open(s, path) ->
+          let env = env_from_summary s subst in
+          let path' = Subst.module_path subst path in
+          let mty =
+            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 mty) env
+    in
+      Hashtbl.add env_cache (sum, subst) env;
+      env
+
+let env_of_only_summary env =
+  Env.env_of_only_summary env_from_summary env
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Module_not_found p ->
+      fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
diff --git a/typing/envaux.mli b/typing/envaux.mli
new file mode 100644
index 00000000..b893c141
--- /dev/null
+++ b/typing/envaux.mli
@@ -0,0 +1,33 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Format
+
+(* Convert environment summaries to environments *)
+
+val env_from_summary : Env.summary -> Subst.t -> Env.t
+
+(* Empty the environment caches. To be called when load_path changes. *)
+
+val reset_cache: unit -> unit
+
+val env_of_only_summary : Env.t -> Env.t
+
+(* Error report *)
+
+type error =
+    Module_not_found of Path.t
+
+exception Error of error
+
+val report_error: formatter -> error -> unit
diff --git a/typing/ident.ml b/typing/ident.ml
index aaf5aaad..70438c83 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ident.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Format
 
 type t = { stamp: int; name: string; mutable flags: int }
@@ -172,13 +170,42 @@ let rec find_name name = function
       else
         find_name name (if c < 0 then l else r)
 
-let rec keys_aux stack accu = function
+let rec get_all = function
+  | None -> []
+  | Some k -> k.data :: get_all k.previous
+
+let rec find_all name = function
+    Empty ->
+      []
+  | Node(l, k, r, _) ->
+      let c = compare name k.ident.name in
+      if c = 0 then
+        k.data :: get_all k.previous
+      else
+        find_all name (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
     Empty ->
       begin match stack with
         [] -> accu
-      | a :: l -> keys_aux l accu a
+      | a :: l -> fold_aux f l accu a
       end
   | Node(l, k, r, _) ->
-      keys_aux (l :: stack) (k.ident :: accu) r
+      fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+  match d with
+    None -> accu
+  | Some k -> f k.ident k.data (fold_data f k.previous accu)
 
-let keys tbl = keys_aux [] [] tbl
+let fold_all f tbl accu =
+  fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
+
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k.ident k.data; iter f r
diff --git a/typing/ident.mli b/typing/ident.mli
index c7d2a071..d1cfa4cc 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ident.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Identifiers (unique names) *)
 
 type t = { stamp: int; name: string; mutable flags: int }
@@ -56,4 +54,7 @@ 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 keys: 'a tbl -> t list
+val find_all: string -> 'a tbl -> 'a list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val iter: (t -> 'a -> unit) -> 'a tbl -> unit
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 90e494eb..2f5aac18 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includeclass.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Inclusion checks for the class language *)
 
 open Types
@@ -49,36 +47,35 @@ let include_err ppf =
   | CM_Parameter_arity_mismatch (ls, lp) ->
       fprintf ppf
         "The classes do not have the same number of type parameters"
-  | CM_Type_parameter_mismatch trace ->
-      fprintf ppf "@[%a@]"
-      (Printtyp.unification_error false trace
+  | CM_Type_parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
         (function ppf ->
-          fprintf ppf "A type parameter has type"))
+          fprintf ppf "A type parameter has type")
         (function ppf ->
           fprintf ppf "but is expected to have type")
-  | CM_Class_type_mismatch (cty1, cty2) ->
-      fprintf ppf
-       "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]"
-       Printtyp.class_type cty1 Printtyp.class_type cty2
-  | CM_Parameter_mismatch trace ->
-      fprintf ppf "@[%a@]"
-      (Printtyp.unification_error false trace
+  | CM_Class_type_mismatch (env, cty1, cty2) ->
+      Printtyp.wrap_printing_env env (fun () ->
+        fprintf ppf
+          "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]"
+          Printtyp.class_type cty1
+          "is not matched by the class type"
+          Printtyp.class_type cty2)
+  | CM_Parameter_mismatch (env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
         (function ppf ->
-          fprintf ppf "A parameter has type"))
+          fprintf ppf "A parameter has type")
         (function ppf ->
           fprintf ppf "but is expected to have type")
-  | CM_Val_type_mismatch (lab, trace) ->
-      fprintf ppf "@[%a@]"
-      (Printtyp.unification_error false trace
+  | CM_Val_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
         (function ppf ->
-          fprintf ppf "The instance variable %s@ has type" lab))
+          fprintf ppf "The instance variable %s@ has type" lab)
         (function ppf ->
           fprintf ppf "but is expected to have type")
-  | CM_Meth_type_mismatch (lab, trace) ->
-      fprintf ppf "@[%a@]"
-      (Printtyp.unification_error false trace
+  | CM_Meth_type_mismatch (lab, env, trace) ->
+      Printtyp.report_unification_error ppf env ~unif:false trace
         (function ppf ->
-          fprintf ppf "The method %s@ has type" lab))
+          fprintf ppf "The method %s@ has type" lab)
         (function ppf ->
           fprintf ppf "but is expected to have type")
   | CM_Non_mutable_value lab ->
diff --git a/typing/includeclass.mli b/typing/includeclass.mli
index 72169a73..48c5c0ca 100644
--- a/typing/includeclass.mli
+++ b/typing/includeclass.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includeclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Inclusion checks for the class language *)
 
 open Types
diff --git a/typing/includecore.ml b/typing/includecore.ml
index c5dc89f0..802dda3b 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -10,11 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includecore.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Inclusion checks for the core language *)
 
-open Misc
 open Asttypes
 open Path
 open Types
@@ -125,12 +122,6 @@ type type_mismatch =
   | Field_missing of bool * Ident.t
   | Record_representation of bool
 
-let nth n =
-  if n = 1 then "first" else
-  if n = 2 then "2nd" else
-  if n = 3 then "3rd" else
-  string_of_int n ^ "th"
-
 let report_type_mismatch0 first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
   match err with
@@ -147,8 +138,8 @@ let report_type_mismatch0 first second decl ppf err =
   | Field_arity s ->
       pr "The arities for field %s differ" (Ident.name s)
   | Field_names (n, name1, name2) ->
-      pr "Their %s fields have different names, %s and %s"
-        (nth n) (Ident.name name1) (Ident.name name2)
+      pr "Fields number %i have different names, %s and %s"
+        n (Ident.name name1) (Ident.name name2)
   | Field_missing (b, s) ->
       pr "The field %s is only present in %s %s"
         (Ident.name s) (if b then second else first) decl
@@ -247,18 +238,20 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
         else [Constraint]
   in
   if err <> [] then err else
-  if match decl2.type_kind with
-  | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private
-  | Type_abstract ->
-      match decl2.type_manifest with
-      | None -> true
-      | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty)
-  then
-    if List.for_all2
-        (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2)&&(not cn1 || cn2))
-        decl1.type_variance decl2.type_variance
-    then [] else [Variance]
-  else []
+  let abstr =
+    decl2.type_private = Private ||
+    decl2.type_kind = Type_abstract && decl2.type_manifest = None in
+  if List.for_all2
+      (fun ty (v1,v2) ->
+        let open Variance in
+        let imp a b = not a || b in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
+        imp abstr (imp co1 co2 && imp cn1 cn2) &&
+        (abstr || Btype.(is_Tvar (repr ty)) || co1 = co2 && cn1 = cn2) &&
+        let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
+        imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
+      decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
+  then [] else [Variance]
 
 (* Inclusion between exception declarations *)
 
diff --git a/typing/includecore.mli b/typing/includecore.mli
index 26ce7b39..08362419 100644
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includecore.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Inclusion checks for the core language *)
 
 open Typedtree
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 985afb54..086dfe4d 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includemod.ml 12520 2012-05-31 07:41:37Z garrigue $ *)
-
 (* Inclusion checks for the module language *)
 
 open Misc
@@ -40,7 +38,7 @@ type symptom =
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-type error = pos list * symptom
+type error = pos list * Env.t * symptom
 
 exception Error of error list
 
@@ -56,7 +54,7 @@ let value_descriptions env cxt subst id vd1 vd2 =
   try
     Includecore.value_descriptions env vd1 vd2
   with Includecore.Dont_match ->
-    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
+    raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
 
 (* Inclusion between type declarations *)
 
@@ -64,7 +62,8 @@ let type_declarations env cxt subst id decl1 decl2 =
   Env.mark_type_used (Ident.name id) decl1;
   let decl2 = Subst.type_declaration subst decl2 in
   let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
-  if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
+  if err <> [] then
+    raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
 
 (* Inclusion between exception declarations *)
 
@@ -73,7 +72,7 @@ let exception_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.exception_declaration subst decl2 in
   if Includecore.exception_declarations env decl1 decl2
   then ()
-  else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
+  else raise(Error[cxt, env, Exception_declarations(id, decl1, decl2)])
 
 (* Inclusion between class declarations *)
 
@@ -82,13 +81,14 @@ let class_type_declarations env cxt subst id decl1 decl2 =
   match Includeclass.class_type_declarations env decl1 decl2 with
     []     -> ()
   | reason ->
-      raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
+      raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)])
 
 let class_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.class_declaration subst decl2 in
   match Includeclass.class_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
+  | reason ->
+      raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
 
 (* Expand a module type identifier when possible *)
 
@@ -98,7 +98,7 @@ let expand_module_path env cxt path =
   try
     Env.find_modtype_expansion path env
   with Not_found ->
-    raise(Error[cxt, Unbound_modtype_path path])
+    raise(Error[cxt, env, Unbound_modtype_path path])
 
 (* Extract name, kind and ident from a signature item *)
 
@@ -120,6 +120,16 @@ let item_ident_name = function
   | Sig_class(id, _, _) -> (id, Field_class(Ident.name id))
   | Sig_class_type(id, _, _) -> (id, Field_classtype(Ident.name id))
 
+let is_runtime_component = function
+  | Sig_value(_,{val_kind = Val_prim _})
+  | Sig_type(_,_,_)
+  | Sig_modtype(_,_)
+  | Sig_class_type(_,_,_) -> false
+  | Sig_value(_,_)
+  | Sig_exception(_,_)
+  | Sig_module(_,_,_)
+  | Sig_class(_, _,_) -> true
+
 (* Simplify a structure coercion *)
 
 let simplify_structure_coercion cc =
@@ -141,9 +151,9 @@ let rec modtypes env cxt subst mty1 mty2 =
     try_modtypes env cxt subst mty1 mty2
   with
     Dont_match ->
-      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
+      raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
   | Error reasons ->
-      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+      raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
                   :: reasons))
 
 and try_modtypes env cxt subst mty1 mty2 =
@@ -186,23 +196,20 @@ and signatures env cxt subst sig1 sig2 =
   (* Build a table of the components of sig1, along with their positions.
      The table is indexed by kind and name of component *)
   let rec build_component_table pos tbl = function
-      [] -> tbl
+      [] -> pos, tbl
     | item :: rem ->
         let (id, name) = item_ident_name item in
-        let nextpos =
-          match item with
-            Sig_value(_,{val_kind = Val_prim _})
-          | Sig_type(_,_,_)
-          | Sig_modtype(_,_)
-          | Sig_class_type(_,_,_) -> pos
-          | Sig_value(_,_)
-          | Sig_exception(_,_)
-          | Sig_module(_,_,_)
-          | Sig_class(_, _,_) -> pos+1 in
+        let nextpos = if is_runtime_component item then pos + 1 else pos in
         build_component_table nextpos
                               (Tbl.add name (id, item, pos) tbl) rem in
-  let comps1 =
+  let len1, comps1 =
     build_component_table 0 Tbl.empty sig1 in
+  let len2 =
+    List.fold_left
+      (fun n i -> if is_runtime_component i then n + 1 else n)
+      0
+      sig2
+  in
   (* Pair each component of sig2 with a component of sig1,
      identifying the names along the way.
      Return a coercion list indicating, for all run-time components
@@ -211,7 +218,14 @@ and signatures env cxt subst sig1 sig2 =
   let rec pair_components subst paired unpaired = function
       [] ->
         begin match unpaired with
-            [] -> signature_components new_env cxt subst (List.rev paired)
+            [] ->
+              let cc =
+                signature_components new_env cxt subst (List.rev paired)
+              in
+              if len1 = len2 then (* see PR#5098 *)
+                simplify_structure_coercion cc
+              else
+                Tcoerce_structure cc
           | _  -> raise(Error unpaired)
         end
     | item2 :: rem ->
@@ -243,11 +257,12 @@ and signatures env cxt subst sig1 sig2 =
             ((item1, item2, pos1) :: paired) unpaired rem
         with Not_found ->
           let unpaired =
-            if report then (cxt, Missing_field id2) :: unpaired else unpaired in
+            if report then (cxt, env, Missing_field id2) :: unpaired
+            else unpaired in
           pair_components subst paired unpaired rem
         end in
   (* Do the pairing and checking, and return the final coercion *)
-  simplify_structure_coercion (pair_components subst [] [] sig2)
+  pair_components subst [] [] sig2
 
 (* Inclusion between signature components *)
 
@@ -298,7 +313,7 @@ and modtype_infos env cxt subst id info1 info2 =
     | (Modtype_abstract, Modtype_manifest mty2) ->
         check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2
   with Error reasons ->
-    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
+    raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
 
 and check_modtype_equiv env cxt mty1 mty2 =
   match
@@ -306,7 +321,7 @@ and check_modtype_equiv env cxt mty1 mty2 =
      modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (_, _) -> raise(Error [cxt, Modtype_permutation])
+  | (_, _) -> raise(Error [cxt, env, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
@@ -326,7 +341,8 @@ let compunit impl_name impl_sig intf_name intf_sig =
   try
     signatures Env.initial [] Subst.identity impl_sig intf_sig
   with Error reasons ->
-    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
+    raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
+                :: reasons))
 
 (* Hide the context and substitution parameters to the outside world *)
 
@@ -446,8 +462,9 @@ let context ppf cxt =
   else
     fprintf ppf "@[At position@ %a@]@ " context cxt
 
-let include_err ppf (cxt, err) =
-  fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err
+let include_err ppf (cxt, env, err) =
+  Printtyp.wrap_printing_env env (fun () ->
+    fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err)
 
 let buffer = ref ""
 let is_big obj =
@@ -463,8 +480,8 @@ let report_error ppf errs =
   if errs = [] then () else
   let (errs , err) = split_last errs in
   let pe = ref true in
-  let include_err' ppf err =
-    if not (is_big err) then fprintf ppf "%a@ " include_err err
+  let include_err' ppf (_,_,obj as err) =
+    if not (is_big obj) then fprintf ppf "%a@ " include_err err
     else if !pe then (fprintf ppf "...@ "; pe := false)
   in
   let print_errs ppf = List.iter (include_err' ppf) in
diff --git a/typing/includemod.mli b/typing/includemod.mli
index 347b1982..75afef57 100644
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: includemod.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Inclusion checks for the module language *)
 
 open Typedtree
@@ -45,7 +43,7 @@ type symptom =
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
-type error = pos list * symptom
+type error = pos list * Env.t * symptom
 
 exception Error of error list
 
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 2e5fd28f..3d7dc223 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mtype.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Operations on module types *)
 
 open Asttypes
diff --git a/typing/mtype.mli b/typing/mtype.mli
index 7e366ad0..0f821d64 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: mtype.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Operations on module types *)
 
 open Types
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 2a7c31d3..479e6fcb 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oprint.ml 11964 2011-12-28 02:22:38Z garrigue $ *)
-
 open Format
 open Outcometree
 
@@ -23,8 +21,9 @@ let cautious f ppf arg =
 
 let rec print_ident ppf =
   function
-    Oide_ident s -> fprintf ppf "%s" s
-  | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
+    Oide_ident s -> pp_print_string ppf s
+  | Oide_dot (id, s) ->
+      print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s
   | Oide_apply (id1, id2) ->
       fprintf ppf "%a(%a)" print_ident id1 print_ident id2
 
@@ -40,7 +39,7 @@ let value_ident ppf name =
   if parenthesized_ident name then
     fprintf ppf "( %s )" name
   else
-    fprintf ppf "%s" name
+    pp_print_string ppf name
 
 (* Values *)
 
@@ -96,7 +95,7 @@ let print_out_value ppf tree =
     | Oval_int32 i -> fprintf ppf "%lil" i
     | Oval_int64 i -> fprintf ppf "%LiL" i
     | Oval_nativeint i -> fprintf ppf "%nin" i
-    | Oval_float f -> fprintf ppf "%s" (float_repres f)
+    | 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
@@ -108,7 +107,7 @@ let print_out_value ppf tree =
         fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
     | Oval_constr (name, []) -> print_ident ppf name
     | Oval_variant (name, None) -> fprintf ppf "`%s" name
-    | Oval_stuff s -> fprintf ppf "%s" s
+    | Oval_stuff s -> pp_print_string ppf s
     | Oval_record fel ->
         fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
     | Oval_ellipsis -> raise Ellipsis
@@ -172,8 +171,13 @@ let rec print_out_type ppf =
 and print_out_type_1 ppf =
   function
     Otyp_arrow (lab, ty1, ty2) ->
-      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
-        print_out_type_2 ty1 print_out_type_1 ty2
+      pp_open_box ppf 0;
+      if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':');
+      print_out_type_2 ppf ty1;
+      pp_print_string ppf " ->";
+      pp_print_space ppf ();
+      print_out_type_1 ppf ty2;
+      pp_close_box ppf ()
   | ty -> print_out_type_2 ppf ty
 and print_out_type_2 ppf =
   function
@@ -186,10 +190,13 @@ and print_simple_out_type ppf =
       fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
         print_ident id
   | Otyp_constr (id, tyl) ->
-      fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+      pp_open_box ppf 0;
+      print_typargs ppf tyl;
+      print_ident ppf id;
+      pp_close_box ppf ()
   | Otyp_object (fields, rest) ->
       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
-  | Otyp_stuff s -> fprintf ppf "%s" s
+  | Otyp_stuff s -> pp_print_string ppf s
   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
   | Otyp_variant (non_gen, row_fields, closed, tags) ->
       let print_present ppf =
@@ -211,7 +218,11 @@ and print_simple_out_type ppf =
         print_fields row_fields
         print_present tags
   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
-      fprintf ppf "@[<1>(%a)@]" print_out_type ty
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_out_type ppf ty;
+      pp_print_char ppf ')';
+      pp_close_box ppf ()
   | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
   | Otyp_module (p, n, tyl) ->
       fprintf ppf "@[<1>(module %s" p;
@@ -252,13 +263,21 @@ and print_typlist print_elem sep ppf =
     [] -> ()
   | [ty] -> print_elem ppf ty
   | ty :: tyl ->
-      fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
-        tyl
+      print_elem ppf ty;
+      pp_print_string ppf sep;
+      pp_print_space ppf ();
+      print_typlist print_elem sep ppf tyl
 and print_typargs ppf =
   function
     [] -> ()
-  | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
-  | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
+  | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf ()
+  | tyl ->
+      pp_open_box ppf 1;
+      pp_print_char ppf '(';
+      print_typlist print_out_type "," ppf tyl;
+      pp_print_char ppf ')';
+      pp_close_box ppf ();
+      pp_print_space ppf ()
 
 let out_type = ref print_out_type
 
@@ -387,7 +406,7 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
   in
   let type_defined ppf =
     match args with
-      [] -> fprintf ppf "%s" name
+      [] -> pp_print_string ppf name
     | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
     | _ ->
         fprintf ppf "@[(@[%a)@]@ %s@]"
@@ -409,7 +428,7 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
   let print_private ppf = function
     Asttypes.Private -> fprintf ppf " private"
   | Asttypes.Public -> () in
-  let rec print_out_tkind ppf = function
+  let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
       fprintf ppf " =%a {%a@;<1 -2>}"
@@ -433,7 +452,7 @@ and print_out_constr ppf (name, tyl,ret_type_opt) =
   | None ->
       begin match tyl with
       | [] ->
-          fprintf ppf "%s" name
+          pp_print_string ppf name
       | _ ->
           fprintf ppf "@[<2>%s of@ %a@]" name
             (print_typlist print_simple_out_type " *") tyl
diff --git a/typing/oprint.mli b/typing/oprint.mli
index a7d18ad1..56caa609 100644
--- a/typing/oprint.mli
+++ b/typing/oprint.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: oprint.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 open Format
 open Outcometree
 
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index e4ed50b9..13b0e6f9 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: outcometree.mli 11160 2011-07-29 10:32:43Z garrigue $ *)
-
 (* Module [Outcometree]: results displayed by the toplevel *)
 
 (* These types represent messages that the toplevel displays as normal
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 9be70433..5490e097 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.ml 12961 2012-09-27 13:30:07Z garrigue $ *)
-
 (* Detection of partial matches and unused match cases. *)
 
 open Misc
@@ -63,9 +61,9 @@ let records_args l1 l2 =
   (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
   let rec combine r1 r2 l1 l2 = match l1,l2 with
   | [],[] -> List.rev r1, List.rev r2
-  | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
-  | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
-  | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 ->
+  | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+  | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+  | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
       if lbl1.lbl_pos < lbl2.lbl_pos then
         combine (p1::r1) (omega::r2) rem1 l2
       else if lbl1.lbl_pos > lbl2.lbl_pos then
@@ -86,7 +84,7 @@ let rec compat p q =
   | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
   | 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, _) ->
+  | Tpat_construct (_, c1,ps1, _), Tpat_construct (_, c2,ps2, _) ->
       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
@@ -126,7 +124,7 @@ let get_type_path ty tenv =
   | Tconstr (path,_,_) -> path
   | _ -> fatal_error "Parmatch.get_type_path"
 
-let rec get_type_descr ty tenv =
+let get_type_descr ty tenv =
   match (Ctype.repr ty).desc with
   | Tconstr (path,_,_) -> Env.find_type path tenv
   | _ -> fatal_error "Parmatch.get_type_descr"
@@ -172,6 +170,14 @@ let is_cons tag v  = match get_constr_name tag v.pat_type v.pat_env with
 | "::" -> true
 | _ -> false
 
+let pretty_const c = match c with
+| Const_int i -> Printf.sprintf "%d" i
+| Const_char c -> Printf.sprintf "%C" c
+| Const_string s -> Printf.sprintf "%S" s
+| Const_float f -> Printf.sprintf "%s" f
+| Const_int32 i -> Printf.sprintf "%ldl" i
+| Const_int64 i -> Printf.sprintf "%LdL" i
+| Const_nativeint i -> Printf.sprintf "%ndn" i
 
 let rec pretty_val ppf v =
   match v.pat_extra with
@@ -188,22 +194,16 @@ let rec pretty_val ppf v =
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
   | Tpat_var (x,_) -> Ident.print ppf x
-  | Tpat_constant (Const_int i) -> fprintf ppf "%d" i
-  | Tpat_constant (Const_char c) -> fprintf ppf "%C" c
-  | Tpat_constant (Const_string s) -> fprintf ppf "%S" s
-  | Tpat_constant (Const_float f) -> fprintf ppf "%s" f
-  | Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
-  | Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
-  | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
+  | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
-  | Tpat_construct (_, _, {cstr_tag=tag},[], _) ->
+  | Tpat_construct (_, {cstr_tag=tag},[], _) ->
       let name = get_constr_name tag v.pat_type v.pat_env in
       fprintf ppf "%s" name
-  | Tpat_construct (_, _, {cstr_tag=tag},[w], _) ->
+  | Tpat_construct (_, {cstr_tag=tag},[w], _) ->
       let name = get_constr_name tag v.pat_type v.pat_env in
       fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
-  | Tpat_construct (_, _, {cstr_tag=tag},vs, _) ->
+  | Tpat_construct (_, {cstr_tag=tag},vs, _) ->
       let name = get_constr_name tag v.pat_type v.pat_env in
       begin match (name, vs) with
         ("::", [v1;v2]) ->
@@ -220,7 +220,7 @@ let rec pretty_val ppf v =
         (pretty_lvals (get_record_labels v.pat_type v.pat_env))
         (List.filter
            (function
-             | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+             | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
              | _ -> true) lvs)
   | Tpat_array vs ->
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
@@ -232,19 +232,19 @@ let rec pretty_val ppf v =
       fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
 
 and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _], _)
+| Tpat_construct (_,{cstr_tag=tag}, [_ ; _], _)
     when is_cons tag v ->
       fprintf ppf "(%a)" pretty_val v
 | _ -> pretty_val ppf v
 
 and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2], _)
+| Tpat_construct (_,{cstr_tag=tag}, [v1 ; v2], _)
     when is_cons tag v ->
       fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
 | _ -> pretty_val ppf v
 
 and pretty_arg ppf v = match v.pat_desc with
-| Tpat_construct (_,_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
+| Tpat_construct (_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
 |  _ -> pretty_val ppf v
 
 and pretty_or ppf v = match v.pat_desc with
@@ -260,10 +260,10 @@ and pretty_vals sep ppf = function
 
 and pretty_lvals lbls ppf = function
   | [] -> ()
-  | [_, _,lbl,v] ->
+  | [_,lbl,v] ->
       let name = find_label lbl lbls in
       fprintf ppf "%s=%a" (Ident.name name) pretty_val v
-  | (_, _, lbl,v)::rest ->
+  | (_, lbl,v)::rest ->
       let name = find_label lbl lbls in
       fprintf ppf "%s=%a;@ %a"
         (Ident.name name) pretty_val v (pretty_lvals lbls) rest
@@ -272,9 +272,29 @@ let top_pretty ppf v =
   fprintf ppf "@[%a@]@?" pretty_val v
 
 
-let prerr_pat v =
-  top_pretty str_formatter v ;
-  prerr_string (flush_str_formatter ())
+let pretty_pat p =
+  top_pretty Format.str_formatter p ;
+  prerr_string (Format.flush_str_formatter ())
+
+type matrix = pattern list list
+
+let pretty_line ps =
+  List.iter
+    (fun p ->
+      top_pretty Format.str_formatter p ;
+      prerr_string " <" ;
+      prerr_string (Format.flush_str_formatter ()) ;
+      prerr_string ">")
+    ps
+
+let pretty_matrix (pss : matrix) =
+  prerr_endline "begin matrix" ;
+  List.iter
+    (fun ps ->
+      pretty_line ps ;
+      prerr_endline "")
+    pss ;
+  prerr_endline "end matrix"
 
 
 (****************************)
@@ -284,7 +304,7 @@ let prerr_pat v =
 (* Check top matching *)
 let simple_match p1 p2 =
   match p1.pat_desc, p2.pat_desc with
-  | Tpat_construct(_, _, c1, _, _), Tpat_construct(_,_, c2, _, _) ->
+  | Tpat_construct(_, c1, _, _), Tpat_construct(_, c2, _, _) ->
       c1.cstr_tag = c2.cstr_tag
   | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
       l1 = l2
@@ -308,26 +328,25 @@ let record_arg p = match p.pat_desc with
 
 (* Raise Not_found when pos is not present in arg *)
 let get_field pos arg =
-  let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in
+  let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
   p
 
 let extract_fields omegas arg =
   List.map
-    (fun (_,_,lbl,_) ->
+    (fun (_,lbl,_) ->
       try
         get_field lbl.lbl_pos arg
       with Not_found -> omega)
     omegas
 
 let all_record_args lbls = match lbls with
-| (_,_,{lbl_all=lbl_all},_)::_ ->
+| (_,{lbl_all=lbl_all},_)::_ ->
     let t =
       Array.map
-        (fun lbl -> Path.Pident (Ident.create "?temp?"),
-          mknoloc (Longident.Lident "?temp?"), lbl,omega)
+        (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
         lbl_all in
     List.iter
-      (fun ((_,_, lbl,_) as x) ->  t.(lbl.lbl_pos) <- x)
+      (fun ((_, lbl,_) as x) ->  t.(lbl.lbl_pos) <- x)
       lbls ;
     Array.to_list t
 |  _ -> fatal_error "Parmatch.all_record_args"
@@ -336,7 +355,7 @@ let all_record_args lbls = match lbls with
 (* Build argument list when p2 >= p1, where p1 is a simple pattern *)
 let rec simple_match_args p1 p2 = match p2.pat_desc with
 | Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_,_, cstr, args, _) -> args
+| Tpat_construct(_, cstr, args, _) -> args
 | Tpat_variant(lab, Some arg, _) -> [arg]
 | Tpat_tuple(args)  -> args
 | Tpat_record(args,_) ->  extract_fields (record_arg p1) args
@@ -344,7 +363,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with
 | Tpat_lazy arg -> [arg]
 | (Tpat_any | Tpat_var(_)) ->
     begin match p1.pat_desc with
-      Tpat_construct(_,_, _,args, _) -> omega_list args
+      Tpat_construct(_, _,args, _) -> omega_list args
     | Tpat_variant(_, Some _, _) -> [omega]
     | Tpat_tuple(args) -> omega_list args
     | Tpat_record(args,_) ->  omega_list args
@@ -365,9 +384,9 @@ let rec normalize_pat q = match q.pat_desc with
   | Tpat_alias (p,_,_) -> normalize_pat p
   | Tpat_tuple (args) ->
       make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
-  | Tpat_construct  (lid, lid_loc, c,args,explicit_arity) ->
+  | Tpat_construct  (lid, c,args,explicit_arity) ->
       make_pat
-        (Tpat_construct (lid, lid_loc, c,omega_list args, explicit_arity))
+        (Tpat_construct (lid, c,omega_list args, explicit_arity))
         q.pat_type q.pat_env
   | Tpat_variant (l, arg, row) ->
       make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
@@ -376,8 +395,8 @@ let rec normalize_pat q = match q.pat_desc with
       make_pat (Tpat_array (omega_list args))  q.pat_type q.pat_env
   | Tpat_record (largs, closed) ->
       make_pat
-        (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) ->
-                                 lid, lid_loc, lbl,omega) largs, closed))
+        (Tpat_record (List.map (fun (lid,lbl,_) ->
+                                 lid, lbl,omega) largs, closed))
         q.pat_type q.pat_env
   | Tpat_lazy _ ->
       make_pat (Tpat_lazy omega) q.pat_type q.pat_env
@@ -402,12 +421,12 @@ let discr_pat q pss =
   | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
       let new_omegas =
         List.fold_right
-          (fun (lid, lid_loc, lbl,_) r ->
+          (fun (lid, lbl,_) r ->
             try
               let _ = get_field lbl.lbl_pos r in
               r
             with Not_found ->
-              (lid, lid_loc, lbl,omega)::r)
+              (lid, lbl,omega)::r)
           largs (record_arg acc)
       in
       acc_pat
@@ -440,22 +459,22 @@ let do_set_args erase_mutable q r = match q with
     let args,rest = read_args omegas r in
     make_pat
       (Tpat_record
-         (List.map2 (fun (lid, lid_loc, lbl,_) arg ->
+         (List.map2 (fun (lid, lbl,_) arg ->
            if
              erase_mutable &&
              (match lbl.lbl_mut with
              | Mutable -> true | Immutable -> false)
            then
-             lid, lid_loc, lbl, omega
+             lid, lbl, omega
            else
-             lid, lid_loc, lbl, arg)
+             lid, lbl, arg)
             omegas args, closed))
       q.pat_type q.pat_env::
     rest
-| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas, explicit_arity)} ->
+| {pat_desc = Tpat_construct (lid, c,omegas, explicit_arity)} ->
     let args,rest = read_args omegas r in
     make_pat
-      (Tpat_construct (lid, lid_loc, c,args, explicit_arity))
+      (Tpat_construct (lid, c,args, explicit_arity))
       q.pat_type q.pat_env::
     rest
 | {pat_desc = Tpat_variant (l, omega, row)} ->
@@ -624,7 +643,7 @@ let row_of_pat pat =
 
 let generalized_constructor x =
   match x with
-    ({pat_desc = Tpat_construct(_,_,c,_, _);pat_env=env},_) ->
+    ({pat_desc = Tpat_construct(_,c,_, _);pat_env=env},_) ->
       c.cstr_generalized
   | _ -> assert false
 
@@ -638,9 +657,9 @@ let clean_env env =
   loop env
 
 let full_match ignore_generalized closing env =  match env with
-| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
+| ({pat_desc = Tpat_construct (_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
     false
-| ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
     if ignore_generalized then
       (* remove generalized constructors;
          those cases will be handled separately *)
@@ -683,12 +702,12 @@ let full_match ignore_generalized closing env =  match env with
 | _ -> fatal_error "Parmatch.full_match"
 
 let full_match_gadt env = match env with
-  | ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+  | ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
     List.length env = c.cstr_consts + c.cstr_nonconsts
   | _ -> true
 
 let extendable_match env = match env with
-| ({pat_desc=Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+| ({pat_desc=Tpat_construct(_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
      as p,_) :: _ ->
     let path = get_type_path p.pat_type p.pat_env in
     not
@@ -702,7 +721,7 @@ let should_extend ext env = match ext with
 | None -> false
 | Some ext -> match env with
   | ({pat_desc =
-      Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+      Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
      as p, _) :: _ ->
       let path = get_type_path p.pat_type p.pat_env in
       Path.same path ext
@@ -732,8 +751,7 @@ let complete_tags nconsts nconstrs tags =
 (* build a pattern from a constructor list *)
 let pat_of_constr ex_pat cstr =
  {ex_pat with pat_desc =
-  Tpat_construct (Path.Pident (Ident.create "?pat_of_constr?"),
-                  mknoloc (Longident.Lident "?pat_of_constr?"),
+  Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
                   cstr,omegas cstr.cstr_arity,false)}
 
 let rec pat_of_constrs ex_pat = function
@@ -771,11 +789,11 @@ let rec map_filter f  =
 (* Sends back a pattern that complements constructor tags all_tag *)
 let complete_constrs p all_tags =
   match p.pat_desc with
-  | Tpat_construct (_,_,c,_,_) ->
+  | Tpat_construct (_,c,_,_) ->
       begin try
         let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
-        let constrs =
-          Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in
+        let (constrs, _) =
+          Env.find_type_descrs (adt_path p.pat_env p.pat_type) p.pat_env in
         map_filter
           (fun cnstr ->
             if List.mem cnstr.cstr_tag not_tags then Some cnstr else None)
@@ -804,22 +822,22 @@ let build_other_constant proj make first next p env =
 
 let build_other ext env =  match env with
 | ({pat_desc =
-    Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
+    Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
   ::_ ->
     make_pat
       (Tpat_construct
-         (lid, lid_loc, {c with
+         (lid, {c with
            cstr_tag=(Cstr_exception
             (Path.Pident (Ident.create "*exception*"), Location.none))},
           [], false))
       Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_,_, _,_,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (_, _,_,_)} as p,_) :: _ ->
     begin match ext with
     | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
         extra_pat
     | _ ->
         let get_tag = function
-          | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+          | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
           | _ -> fatal_error "Parmatch.get_tag" in
         let all_tags =  List.map (fun (p,_) -> get_tag p) env in
         pat_of_constrs p (complete_constrs p all_tags)
@@ -936,7 +954,7 @@ let build_other_gadt ext env =
   match env with
     | ({pat_desc = Tpat_construct _} as p,_) :: _ ->
         let get_tag = function
-          | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+          | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
           | _ -> fatal_error "Parmatch.get_tag" in
         let all_tags =  List.map (fun (p,_) -> get_tag p) env in
         let cnstrs  = complete_constrs p all_tags in
@@ -960,9 +978,9 @@ let rec has_instance p = match p.pat_desc with
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
   | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
   | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
-  | Tpat_construct (_, _,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
+  | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
       has_instances ps
-  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps)
+  | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
   | Tpat_lazy p
     -> has_instance p
 
@@ -1012,7 +1030,7 @@ type 'a result =
   | Rsome of 'a     (* This matching value *)
 
 let rec orify_many =
-  let rec orify x y =
+  let orify x y =
     make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env
   in
   function
@@ -1027,20 +1045,16 @@ let rec try_many  f = function
       | Rnone -> try_many  f rest
       | r -> r
 
+let rappend r1 r2 =
+  match r1, r2 with
+  | Rnone, _ -> r2
+  | _, Rnone -> r1
+  | Rsome l1, Rsome l2 -> Rsome (l1 @ l2)
 
 let rec try_many_gadt  f = function
   | [] -> Rnone
   | (p,pss)::rest ->
-      match f (p,pss) with
-      | Rnone -> try_many f rest
-      | Rsome sofar ->
-          let others = try_many f rest in
-          match others with
-            Rnone -> Rsome sofar
-          | Rsome sofar' ->
-              Rsome (sofar @ sofar')
-
-
+      rappend (f (p, pss)) (try_many_gadt f rest)
 
 let rec exhaust ext pss n = match pss with
 | []    ->  Rsome (omegas n)
@@ -1171,18 +1185,15 @@ let rec exhaust_gadt (ext:Path.t option) pss n = match pss with
           | Rsome r ->
               try
                 let missing_trailing = build_other_gadt ext constrs in
-                let before =
-                  match before with
-                    Rnone -> []
-                  | Rsome lst -> lst
-                in
                 let dug =
                   combinations
                     (fun head tail -> head :: tail)
                     missing_trailing
                     r
                 in
-                Rsome (dug @ before)
+                match before with
+                | Rnone -> Rsome dug
+                | Rsome x -> Rsome (x @ dug)
               with
       (* cannot occur, since constructors don't make a full signature *)
               | Empty -> fatal_error "Parmatch.exhaust"
@@ -1266,29 +1277,6 @@ type answer =
   | Upartial of Typedtree.pattern list  (* Mixed, with list of useless ones *)
 
 
-let pretty_pat p =
-  top_pretty Format.str_formatter p ;
-  prerr_string (Format.flush_str_formatter ())
-
-type matrix = pattern list list
-
-let pretty_line ps =
-  List.iter
-    (fun p ->
-      top_pretty Format.str_formatter p ;
-      prerr_string " <" ;
-      prerr_string (Format.flush_str_formatter ()) ;
-      prerr_string ">")
-    ps
-
-let pretty_matrix pss =
-  prerr_endline "begin matrix" ;
-  List.iter
-    (fun ps ->
-      pretty_line ps ;
-      prerr_endline "")
-    pss ;
-  prerr_endline "end matrix"
 
 (* this row type enable column processing inside the matrix
     - left  ->  elements not to be processed,
@@ -1528,7 +1516,7 @@ let rec le_pat p q =
   | Tpat_alias(p,_,_), _ -> 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,_) ->
+  | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
       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)
@@ -1578,10 +1566,10 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
 | Tpat_lazy p, Tpat_lazy q ->
     let r = lub p q in
     make_pat (Tpat_lazy r) p.pat_type p.pat_env
-| Tpat_construct (lid, lid_loc, c1,ps1,_), Tpat_construct (_, _,c2,ps2,_)
+| Tpat_construct (lid, c1,ps1,_), Tpat_construct (_,c2,ps2,_)
       when  c1.cstr_tag = c2.cstr_tag  ->
         let rs = lubs ps1 ps2 in
-        make_pat (Tpat_construct (lid, lid_loc, c1,rs, false))
+        make_pat (Tpat_construct (lid, c1,rs, false))
           p.pat_type p.pat_env
 | Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
           when  l1=l2 ->
@@ -1613,13 +1601,13 @@ and record_lubs l1 l2 =
   let rec lub_rec l1 l2 = match l1,l2 with
   | [],_ -> l2
   | _,[] -> l1
-  | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 ->
+  | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
       if lbl1.lbl_pos < lbl2.lbl_pos then
-        (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2
+        (lid1, lbl1,p1)::lub_rec rem1 l2
       else if lbl2.lbl_pos < lbl1.lbl_pos  then
-        (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2
+        (lid2, lbl2,p2)::lub_rec l1 rem2
       else
-        (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+        (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
   lub_rec l1 l2
 
 and lubs ps qs = match ps,qs with
@@ -1760,15 +1748,15 @@ module Conv = struct
       | _ -> []
 
   let name_counter = ref 0
-  let fresh () =
+  let fresh name =
     let current = !name_counter in
     name_counter := !name_counter + 1;
-    "#$%^@*@" ^ string_of_int current
+    "#$" ^ name ^ string_of_int current
 
   let conv (typed: Typedtree.pattern) :
       Parsetree.pattern list *
-      (string,Path.t * Types.constructor_description) Hashtbl.t *
-      (string,Path.t * Types.label_description) Hashtbl.t
+      (string, Types.constructor_description) Hashtbl.t *
+      (string, Types.label_description) Hashtbl.t
       =
     let constrs = Hashtbl.create 0 in
     let labels = Hashtbl.create 0 in
@@ -1784,10 +1772,10 @@ module Conv = struct
           List.map
             (fun lst -> mkpat (Ppat_tuple lst))
             results
-      | Tpat_construct (cstr_path, cstr_lid, cstr,lst,_) ->
-          let id = fresh () in
+      | Tpat_construct (cstr_lid, cstr,lst,_) ->
+          let id = fresh cstr.cstr_name in
           let lid = { cstr_lid with txt = Longident.Lident id } in
-          Hashtbl.add constrs id (cstr_path,cstr);
+          Hashtbl.add constrs id cstr;
           let results = select (List.map loop lst) in
           begin match lst with
             [] ->
@@ -1818,13 +1806,13 @@ module Conv = struct
       | Tpat_record (subpatterns, _closed_flag) ->
           let pats =
             select
-              (List.map (fun (_,_,_,x) -> (loop x)) subpatterns)
+              (List.map (fun (_,_,x) -> loop x) subpatterns)
           in
           let label_idents =
             List.map
-              (fun (lbl_path,_,lbl,_) ->
-                let id = fresh () in
-                Hashtbl.add labels id (lbl_path, lbl);
+              (fun (_,lbl,_) ->
+                let id = fresh lbl.lbl_name in
+                Hashtbl.add labels id lbl;
                 Longident.Lident id)
               subpatterns
           in
@@ -1932,7 +1920,7 @@ let extendable_path path =
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
     let path =  get_type_path p.pat_type p.pat_env in
     List.fold_left
       collect_paths_from_pat
@@ -1940,11 +1928,11 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
       ps
 | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
 | Tpat_tuple ps | Tpat_array ps
-| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps,_)->
+| Tpat_construct (_, {cstr_tag=Cstr_exception _}, ps,_)->
     List.fold_left collect_paths_from_pat r ps
 | Tpat_record (lps,_) ->
     List.fold_left
-      (fun r (_, _, _, p) -> collect_paths_from_pat r p)
+      (fun r (_, _, p) -> collect_paths_from_pat r p)
       r lps
 | Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
 | Tpat_or (p1,p2,_) ->
@@ -2034,12 +2022,12 @@ let rec inactive pat = match pat with
     false
 | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
     true
-| Tpat_tuple ps | Tpat_construct (_, _, _, ps,_) | Tpat_array ps ->
+| 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
+    List.exists (fun (_, _, p) -> inactive p.pat_desc) ldps
 | Tpat_or (p,q,_) ->
     inactive p.pat_desc && inactive q.pat_desc
 
@@ -2089,5 +2077,7 @@ let check_partial_gadt pred loc casel =
   | Partial -> Partial
   | Total ->
       (* checks for missing GADT constructors *)
+      (* let casel =
+        match casel with [] -> [] | a :: l -> a :: l @ [a] in *)
       check_partial_param (do_check_partial_gadt pred)
         do_check_fragile_gadt loc casel
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index dfe0e7da..ffb0b906 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -10,13 +10,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.mli 12961 2012-09-27 13:30:07Z garrigue $ *)
-
 (* Detection of partial matches and unused match cases. *)
 open Asttypes
 open Typedtree
 open Types
 
+val pretty_const : constant -> string
 val top_pretty : Format.formatter -> pattern -> unit
 val pretty_pat : pattern -> unit
 val pretty_line : pattern list -> unit
@@ -27,8 +26,8 @@ val omegas : int -> pattern list
 val omega_list : 'a list -> pattern list
 val normalize_pat : pattern -> pattern
 val all_record_args :
-    (Path.t * Longident.t loc * label_description * pattern) list ->
-    (Path.t * Longident.t loc * label_description * pattern) list
+    (Longident.t loc * label_description * pattern) list ->
+    (Longident.t loc * label_description * pattern) list
 val const_compare : constant -> constant -> int
 
 val le_pat : pattern -> pattern -> bool
@@ -41,7 +40,7 @@ val lubs : pattern list -> pattern list -> pattern list
 
 val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
 
-(* Those to functions recombine one pattern and its arguments:
+(* Those two functions recombine one pattern and its arguments:
    For instance:
      (_,_)::p1::p2::rem -> (p1, p2)::rem
    The second one will replace mutable arguments by '_'
@@ -56,8 +55,8 @@ val complete_constrs :
 val pressure_variants: Env.t -> pattern list -> unit
 val check_partial: Location.t -> (pattern * expression) list -> partial
 val check_partial_gadt:
-    ((string,Path.t * constructor_description) Hashtbl.t ->
-     (string,Path.t * label_description) Hashtbl.t ->
+    ((string, constructor_description) Hashtbl.t ->
+     (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
     Location.t -> (pattern * expression) list -> partial
 val check_unused: Env.t -> (pattern * expression) list -> unit
diff --git a/typing/path.ml b/typing/path.ml
index 2b19a9f9..260fc073 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: path.ml 12035 2012-01-18 09:15:27Z frisch $ *)
-
 type t =
     Pident of Ident.t
   | Pdot of t * string * int
diff --git a/typing/path.mli b/typing/path.mli
index aa9b9996..c3f84130 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: path.mli 12035 2012-01-18 09:15:27Z frisch $ *)
-
 (* Access paths *)
 
 type t =
diff --git a/typing/predef.ml b/typing/predef.ml
index 0b1fc340..e4e96d2d 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -10,11 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: predef.ml 12520 2012-05-31 07:41:37Z garrigue $ *)
-
 (* Predefined type constructors (with special typing rules in typecore) *)
 
-open Asttypes
 open Path
 open Types
 open Btype
@@ -94,6 +91,16 @@ let path_match_failure = Pident ident_match_failure
 and path_assert_failure = Pident ident_assert_failure
 and path_undefined_recursive_module = Pident ident_undefined_recursive_module
 
+let decl_abstr =
+  {type_params = [];
+   type_arity = 0;
+   type_kind = Type_abstract;
+   type_loc = Location.none;
+   type_private = Asttypes.Public;
+   type_manifest = None;
+   type_variance = [];
+   type_newtype_level = None}
+
 let ident_false = ident_create "false"
 and ident_true = ident_create "true"
 and ident_void = ident_create "()"
@@ -102,100 +109,49 @@ and ident_cons = ident_create "::"
 and ident_none = ident_create "None"
 and ident_some = ident_create "Some"
 let build_initial_env add_type add_exception empty_env =
-  let decl_abstr =
-    {type_params = [];
-     type_arity = 0;
-     type_kind = Type_abstract;
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [];
-     type_newtype_level = None}
-  and decl_bool =
-    {type_params = [];
-     type_arity = 0;
-     type_kind = Type_variant([ident_false, [], None; ident_true, [], None]);
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [];
-     type_newtype_level = None}
+  let decl_bool =
+    {decl_abstr with
+     type_kind = Type_variant([ident_false, [], None; ident_true, [], None])}
   and decl_unit =
-    {type_params = [];
-     type_arity = 0;
-     type_kind = Type_variant([ident_void, [], None]);
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [];
-     type_newtype_level = None}
+    {decl_abstr with
+     type_kind = Type_variant([ident_void, [], None])}
   and decl_exn =
-    {type_params = [];
-     type_arity = 0;
-     type_kind = Type_variant [];
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [];
-     type_newtype_level = None}
+    {decl_abstr with
+     type_kind = Type_variant []}
   and decl_array =
     let tvar = newgenvar() in
-    {type_params = [tvar];
+    {decl_abstr with
+     type_params = [tvar];
      type_arity = 1;
-     type_kind = Type_abstract;
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [true, true, true];
-     type_newtype_level = None}
+     type_variance = [Variance.full]}
   and decl_list =
     let tvar = newgenvar() in
-    {type_params = [tvar];
+    {decl_abstr with
+     type_params = [tvar];
      type_arity = 1;
      type_kind =
      Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar],
                    None]);
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [true, false, false];
-     type_newtype_level = None}
+     type_variance = [Variance.covariant]}
   and decl_format6 =
-    {type_params = [
-     newgenvar(); newgenvar(); newgenvar();
-     newgenvar(); newgenvar(); newgenvar();
-   ];
+    let params = List.map newgenvar [();();();();();()] in
+    {decl_abstr with
+     type_params = params;
      type_arity = 6;
-     type_kind = Type_abstract;
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [
-     true, true, true; true, true, true;
-     true, true, true; true, true, true;
-     true, true, true; true, true, true;
-   ];
-     type_newtype_level = None}
+     type_variance = List.map (fun _ -> Variance.full) params}
   and decl_option =
     let tvar = newgenvar() in
-    {type_params = [tvar];
+    {decl_abstr with
+     type_params = [tvar];
      type_arity = 1;
      type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]);
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [true, false, false];
-     type_newtype_level = None}
+     type_variance = [Variance.covariant]}
   and decl_lazy_t =
     let tvar = newgenvar() in
-    {type_params = [tvar];
+    {decl_abstr with
+     type_params = [tvar];
      type_arity = 1;
-     type_kind = Type_abstract;
-     type_loc = Location.none;
-     type_private = Public;
-     type_manifest = None;
-     type_variance = [true, false, false];
-     type_newtype_level = None}
+     type_variance = [Variance.covariant]}
   in
 
   let add_exception id l =
diff --git a/typing/predef.mli b/typing/predef.mli
index a582bed4..a2f47247 100644
--- a/typing/predef.mli
+++ b/typing/predef.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: predef.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Predefined type constructors (with special typing rules in typecore) *)
 
 open Types
diff --git a/typing/primitive.ml b/typing/primitive.ml
index 41c2bb83..17abeb34 100644
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: primitive.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Description of primitive functions *)
 
 open Misc
diff --git a/typing/primitive.mli b/typing/primitive.mli
index a9b25048..585dba0d 100644
--- a/typing/primitive.mli
+++ b/typing/primitive.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: primitive.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Description of primitive functions *)
 
 type description =
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index e22c4a74..d996c052 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printtyp.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Printing functions *)
 
 open Misc
@@ -27,7 +25,7 @@ open Outcometree
 (* Print a long identifier *)
 
 let rec longident ppf = function
-  | Lident s -> fprintf ppf "%s" s
+  | Lident s -> pp_print_string ppf s
   | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
   | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
 
@@ -43,7 +41,7 @@ let add_unique id =
   with Not_found ->
     unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names
 
-let ident ppf id = fprintf ppf "%s" (ident_name id)
+let ident ppf id = pp_print_string ppf (ident_name id)
 
 (* Print a path *)
 
@@ -63,12 +61,23 @@ let rec path ppf = function
   | Pident id ->
       ident ppf id
   | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
-      fprintf ppf "%s" s
+      pp_print_string ppf s
   | Pdot(p, s, pos) ->
-      fprintf ppf "%a.%s" path p s
+      path ppf p;
+      pp_print_char ppf '.';
+      pp_print_string ppf s
   | Papply(p1, p2) ->
       fprintf ppf "%a(%a)" path p1 path p2
 
+let rec string_of_out_ident = function
+  | Oide_ident s -> s
+  | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
+  | Oide_apply (id1, id2) ->
+      String.concat ""
+        [string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
+
+let string_of_path p = string_of_out_ident (tree_of_path p)
+
 (* Print a recursive annotation *)
 
 let tree_of_rec = function
@@ -189,6 +198,168 @@ let raw_type_expr ppf t =
 
 let () = Btype.print_raw := raw_type_expr
 
+(* Normalize paths *)
+
+type param_subst = Id | Nth of int | Map of int list
+
+let compose l1 = function
+  | Id -> Map l1
+  | Map l2 -> Map (List.map (List.nth l1) l2)
+  | 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
+
+type best_path = Paths of Path.t list | Best of Path.t
+
+let printing_env = ref Env.empty
+let printing_old = ref Env.empty
+let printing_pers = ref Concr.empty
+module Path2 = struct
+  include Path
+  let rec compare p1 p2 =
+    (* must ignore position when comparing paths *)
+    match (p1, p2) with
+      (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) ->
+        let c = compare p1 p2 in
+        if c <> 0 then c else String.compare s1 s2
+    | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+        let c = compare fun1 fun2 in
+        if c <> 0 then c else compare arg1 arg2
+    | _ -> Pervasives.compare p1 p2
+end
+module PathMap = Map.Make(Path2)
+let printing_map = ref (Lazy.lazy_from_val PathMap.empty)
+
+let same_type t t' = repr t == repr t'
+
+let rec index l x =
+  match l with
+    [] -> raise Not_found
+  | a :: l -> if x == a then 0 else 1 + index l x
+
+let rec uniq = function
+    [] -> true
+  | a :: l -> not (List.memq a l) && uniq l
+
+let rec normalize_type_path ?(cache=false) env p =
+  try
+    let desc = Env.find_type p env in
+    if desc.type_private = Private || desc.type_newtype_level <> None then
+      (p, Id)
+    else match desc.type_manifest with
+      Some ty ->
+        let params = List.map repr desc.type_params in
+        begin match repr ty with
+          {desc = Tconstr (p1, tyl, _)} ->
+            let tyl = List.map repr tyl in
+            if List.length params = List.length tyl
+            && List.for_all2 (==) params tyl
+            then normalize_type_path ~cache env p1
+            else if cache || List.length params <= List.length tyl
+                 || not (uniq tyl) then (p, Id)
+            else
+              let l1 = List.map (index params) tyl in
+              let (p2, s2) = normalize_type_path ~cache env p1 in
+              (p2, compose l1 s2)
+        | ty ->
+            (p, Nth (index params ty))
+        end
+    | None -> (p, Id)
+  with
+    Not_found -> (p, Id)
+
+let rec path_size = function
+    Pident id ->
+      (let s = Ident.name id in if s <> "" && s.[0] = '_' then 10 else 1),
+      -Ident.binding_time id
+  | Pdot (p, _, _) ->
+      let (l, b) = path_size p in (1+l, b)
+  | Papply (p1, p2) ->
+      let (l, b) = path_size p1 in
+      (l + fst (path_size p2), b)
+
+let same_printing_env env =
+  let used_pers = Env.used_persistent () in
+  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
+  begin
+    (* printf "Reset printing_map@."; *)
+    printing_old := env;
+    printing_pers := Env.used_persistent ();
+    printing_map := lazy begin
+      (* printf "Recompute printing_map.@."; *)
+      let map = ref PathMap.empty in
+      Env.iter_types
+        (fun p (p', decl) ->
+          let (p1, s1) = normalize_type_path env p' ~cache:true in
+          (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
+          if s1 = Id then
+          try
+            let r = PathMap.find p1 !map in
+            match !r with
+              Paths l -> r := Paths (p :: l)
+            | Best _  -> assert false
+          with Not_found ->
+            map := PathMap.add p1 (ref (Paths [p])) !map)
+        env;
+      !map
+    end
+  end
+
+let wrap_printing_env env f =
+  set_printing_env env;
+  try_finally f (fun () -> set_printing_env Env.empty)
+
+let is_unambiguous path env =
+  let l = Env.find_shadowed_types path env in
+  List.exists (Path.same path) l || (* concrete paths are ok *)
+  match l with
+    [] -> true
+  | p :: rem ->
+      (* allow also coherent paths:  *)
+      let normalize p = fst (normalize_type_path ~cache:true env p) in
+      let p' = normalize p in
+      List.for_all (fun p -> Path.same (normalize p) p') rem ||
+      (* also allow repeatedly defining and opening (for toplevel) *)
+      let id = lid_of_path p in
+      List.for_all (fun p -> lid_of_path p = id) rem &&
+      Path.same p (fst (Env.lookup_type id env))
+
+let rec get_best_path r =
+  match !r with
+    Best p' -> p'
+  | Paths [] -> raise Not_found
+  | Paths l ->
+      r := Paths [];
+      List.iter
+        (fun p ->
+          (* Format.eprintf "evaluating %a@." path p; *)
+          match !r with
+            Best p' when path_size p >= path_size p' -> ()
+          | _ -> if is_unambiguous p !printing_env then r := Best p)
+              (* else Format.eprintf "%a ignored as ambiguous@." path p *)
+        l;
+      get_best_path r
+
+let best_type_path p =
+  if !Clflags.real_paths || !printing_env == Env.empty
+  then (p, Id)
+  else
+    let (p', s) = normalize_type_path !printing_env p in
+    let p'' =
+      try get_best_path (PathMap.find  p' (Lazy.force !printing_map))
+      with Not_found -> p'
+    in
+    (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *)
+    (p'', s)
+
 (* Print a type expression *)
 
 let names = ref ([] : (type_expr * string) list)
@@ -269,7 +440,11 @@ let add_alias ty =
   end
 
 let aliasable ty =
-  match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
+  match ty.desc with
+    Tvar _ | Tunivar _ | Tpoly _ -> false
+  | Tconstr (p, _, _) ->
+      (match best_type_path p with (_, Nth _) -> false | _ -> true)
+  | _ -> true
 
 let namable_row row =
   row.row_name <> None &&
@@ -291,7 +466,10 @@ let rec mark_loops_rec visited ty =
     | Tarrow(_, ty1, ty2, _) ->
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
-    | Tconstr(_, tyl, _) | Tpackage (_, _, tyl) ->
+    | Tconstr(p, tyl, _) ->
+        let (p', s) = best_type_path p in
+        List.iter (mark_loops_rec visited) (apply_subst s tyl)
+    | Tpackage (_, _, tyl) ->
         List.iter (mark_loops_rec visited) tyl
     | Tvariant row ->
         if List.memq px !visited_objects then add_alias px else
@@ -384,7 +562,12 @@ let rec tree_of_typexp sch ty =
     | Ttuple tyl ->
         Otyp_tuple (tree_of_typlist sch tyl)
     | Tconstr(p, tyl, abbrev) ->
-        Otyp_constr (tree_of_path p, tree_of_typlist sch tyl)
+        begin match best_type_path p with
+          (_, Nth n) -> tree_of_typexp sch (List.nth tyl n)
+        | (p', s) ->
+            let tyl' = apply_subst s tyl in
+            Otyp_constr (tree_of_path p', tree_of_typlist sch tyl')
+        end
     | Tvariant row ->
         let row = row_repr row in
         let fields =
@@ -402,7 +585,9 @@ let rec tree_of_typexp sch ty =
         let all_present = List.length present = List.length fields in
         begin match row.row_name with
         | Some(p, tyl) when namable_row row ->
-            let id = tree_of_path p in
+            let (p', s) = best_type_path p in
+            assert (s = Id);
+            let id = tree_of_path p' in
             let args = tree_of_typlist sch tyl in
             if row.row_closed && all_present then
               Otyp_constr (id, args)
@@ -410,7 +595,7 @@ let rec tree_of_typexp sch ty =
               let non_gen = is_non_gen sch px in
               let tags =
                 if all_present then None else Some (List.map fst present) in
-              Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
+              Otyp_variant (non_gen, Ovar_name(id, args),
                             row.row_closed, tags)
         | _ ->
             let non_gen =
@@ -492,7 +677,9 @@ and tree_of_typobject sch fi nm =
   | Some (p, ty :: tyl) ->
       let non_gen = is_non_gen sch (repr ty) in
       let args = tree_of_typlist sch tyl in
-      Otyp_class (non_gen, tree_of_path p, args)
+      let (p', s) = best_type_path p in
+      assert (s = Id);
+      Otyp_class (non_gen, tree_of_path p', args)
   | _ ->
       fatal_error "Printtyp.tree_of_typobject"
   end
@@ -564,6 +751,17 @@ let rec tree_of_type_decl id decl =
 
   let params = filter_params decl.type_params in
 
+  begin match decl.type_manifest with
+  | Some ty ->
+      let vars = free_variables ty in
+      List.iter
+        (function {desc = Tvar (Some "_")} as ty ->
+            if List.memq ty vars then ty.desc <- Tvar None
+          | _ -> ())
+        params
+  | None -> ()
+  end;
+
   List.iter add_alias params;
   List.iter mark_loops params;
   List.iter check_name_of_type (List.map proxy params);
@@ -615,8 +813,9 @@ let rec tree_of_type_decl id decl =
     in
     let vari =
       List.map2
-        (fun ty (co,cn,ct) ->
-          if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
+        (fun ty v ->
+          if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v
+          else (true,true))
         decl.type_params decl.type_variance
     in
     (Ident.name id,
@@ -811,6 +1010,9 @@ let tree_of_class_params params =
   let tyl = tree_of_typlist true params in
   List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
 
+let class_variance =
+  List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
+
 let tree_of_class_declaration id cl rs =
   let params = filter_params cl.cty_params in
 
@@ -826,7 +1028,7 @@ let tree_of_class_declaration id cl rs =
   let vir_flag = cl.cty_new = None in
   Osig_class
     (vir_flag, Ident.name id,
-     List.map2 tree_of_class_param params cl.cty_variance,
+     List.map2 tree_of_class_param params (class_variance cl.cty_variance),
      tree_of_class_type true params cl.cty_type,
      tree_of_rec rs)
 
@@ -859,7 +1061,7 @@ let tree_of_cltype_declaration id cl rs =
 
   Osig_class_type
     (virt, Ident.name id,
-     List.map2 tree_of_class_param params cl.clty_variance,
+     List.map2 tree_of_class_param params (class_variance cl.clty_variance),
      tree_of_class_type true params cl.clty_type,
      tree_of_rec rs)
 
@@ -868,6 +1070,42 @@ let cltype_declaration id ppf cl =
 
 (* Print a module type *)
 
+let wrap_env fenv ftree arg =
+  let env = !printing_env in
+  set_printing_env (fenv env);
+  let tree = ftree arg in
+  set_printing_env env;
+  tree
+
+let filter_rem_sig item rem =
+  match item, rem with
+  | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem ->
+      ([ctydecl; tydecl1; tydecl2], rem)
+  | Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
+      ([tydecl1; tydecl2], rem)
+  | _ ->
+      ([], rem)
+
+let dummy =
+  { type_params = []; type_arity = 0; type_kind = Type_abstract;
+    type_private = Public; type_manifest = None; type_variance = [];
+    type_newtype_level = None; type_loc = Location.none; }
+
+let hide_rec_items = function
+  | Sig_type(id, decl, rs) ::rem
+    when rs <> Trec_next && not !Clflags.real_paths ->
+      let rec get_ids = function
+          Sig_type (id, _, Trec_next) :: rem ->
+            id :: get_ids rem
+        | _ -> []
+      in
+      let ids = id :: get_ids rem in
+      set_printing_env
+        (List.fold_right
+           (fun id -> Env.add_type (Ident.rename id) dummy)
+           ids !printing_env)
+  | _ -> ()
+
 let rec tree_of_modtype = function
   | Mty_ident p ->
       Omty_ident (tree_of_path p)
@@ -875,30 +1113,42 @@ let rec tree_of_modtype = function
       Omty_signature (tree_of_signature sg)
   | Mty_functor(param, ty_arg, ty_res) ->
       Omty_functor
-        (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res)
-
-and tree_of_signature = function
-  | [] -> []
-  | Sig_value(id, decl) :: rem ->
-      tree_of_value_description id decl :: tree_of_signature rem
-  | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
-      tree_of_signature rem
-  | Sig_type(id, decl, rs) :: rem ->
-      Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
-      tree_of_signature rem
-  | Sig_exception(id, decl) :: rem ->
-      tree_of_exception_declaration id decl :: tree_of_signature rem
-  | Sig_module(id, mty, rs) :: rem ->
-      Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
-      tree_of_signature rem
-  | Sig_modtype(id, decl) :: rem ->
-      tree_of_modtype_declaration id decl :: tree_of_signature rem
-  | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
-      tree_of_class_declaration id decl rs :: tree_of_signature rem
-  | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
-      tree_of_cltype_declaration id decl rs :: tree_of_signature rem
-  | _ ->
-      assert false
+        (Ident.name param, tree_of_modtype ty_arg,
+         wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res)
+
+and tree_of_signature sg =
+  wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg
+
+and tree_of_signature_rec env' = function
+    [] -> []
+  | item :: rem ->
+      begin match item with
+        Sig_type (_, _, rs) when rs <> Trec_next -> ()
+      | _ -> set_printing_env env'
+      end;
+      let (sg, rem) = filter_rem_sig item rem in
+      let trees =
+        match item with
+        | Sig_value(id, decl) ->
+            [tree_of_value_description id decl]
+        | Sig_type(id, _, _) when is_row_name (Ident.name id) ->
+            []
+        | Sig_type(id, decl, rs) ->
+            hide_rec_items (item :: rem);
+            [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)]
+        | Sig_exception(id, decl) ->
+            [tree_of_exception_declaration id decl]
+        | Sig_module(id, mty, rs) ->
+            [Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)]
+        | Sig_modtype(id, decl) ->
+            [tree_of_modtype_declaration id decl]
+        | Sig_class(id, decl, rs) ->
+            [tree_of_class_declaration id decl rs]
+        | Sig_class_type(id, decl, rs) ->
+            [tree_of_cltype_declaration id decl rs]
+      in
+      let env' = Env.add_signature (item :: sg) env' in
+      trees @ tree_of_signature_rec env' rem
 
 and tree_of_modtype_declaration id decl =
   let mty =
@@ -925,11 +1175,32 @@ let signature ppf sg =
 
 (* Print an unification error *)
 
+let same_path t t' =
+  let t = repr t and t' = repr t' in
+  t == t' ||
+  match t.desc, t'.desc with
+    Tconstr(p,tl,_), Tconstr(p',tl',_) ->
+      let (p1, s1) = best_type_path p and (p2, s2)  = best_type_path p' in
+      begin match s1, s2 with
+        Nth n1, Nth n2 when n1 = n2 -> true
+      | (Id | Map _), (Id | Map _) when Path.same p1 p2 ->
+          let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in
+          List.length tl = List.length tl' &&
+          List.for_all2 same_type tl tl'
+      | _ -> false
+      end
+  | _ ->
+      false
+
 let type_expansion t ppf t' =
-  if t == t' then type_expr ppf t else
+  if same_path t t' then type_expr ppf t else
   let t' = if proxy t == proxy t' then unalias t' else t' in
   fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
 
+let type_path_expansion tp ppf tp' =
+  if Path.same tp tp' then path ppf tp else
+  fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
+
 let rec trace fst txt ppf = function
   | (t1, t1') :: (t2, t2') :: rem ->
       if not fst then fprintf ppf "@,";
@@ -938,16 +1209,25 @@ let rec trace fst txt ppf = function
        (trace false txt) rem
   | _ -> ()
 
-let rec filter_trace = function
+let rec filter_trace keep_last = function
   | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
       []
   | (t1, t1') :: (t2, t2') :: rem ->
-      let rem' = filter_trace rem in
-      if t1 == t1' && t2 == t2'
+      let rem' = filter_trace keep_last rem in
+      if is_constr_row t1' || is_constr_row t2'
+      || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
       then rem'
       else (t1, t1') :: (t2, t2') :: rem'
   | _ -> []
 
+let rec type_path_list ppf = function
+  | [tp, tp'] -> type_path_expansion tp ppf tp'
+  | (tp, tp') :: rem ->
+      fprintf ppf "%a@;<2 0>%a"
+        (type_path_expansion tp) tp'
+        type_path_list rem
+  | [] -> ()
+
 (* Hide variant name and var, to force printing the expanded type *)
 let hide_variant_name t =
   match repr t with
@@ -959,7 +1239,8 @@ let hide_variant_name t =
 
 let prepare_expansion (t, t') =
   let t' = hide_variant_name t' in
-  mark_loops t; if t != t' then mark_loops t';
+  mark_loops t;
+  if not (same_path t t') then mark_loops t';
   (t, t')
 
 let may_prepare_expansion compact (t, t') =
@@ -977,6 +1258,7 @@ let print_tags ppf fields =
 let has_explanation unif t3 t4 =
   match t3.desc, t4.desc with
     Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
+  | Tnil, Tconstr _ | Tconstr _, Tnil
   | _, Tvar _ | Tvar _, _
   | Tvariant _, Tvariant _ -> true
   | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
@@ -1030,6 +1312,10 @@ let explanation unif t3 t4 ppf =
   | Tfield (l, _, _, _), (Tnil|Tconstr _) ->
       fprintf ppf
         "@,@[The second object type has no method %s@]" l
+  | Tnil, Tconstr _ | Tconstr _, Tnil ->
+      fprintf ppf
+        "@,@[The %s object type has an abstract row, it cannot be closed@]"
+        (if t4.desc = Tnil then "first" else "second")
   | Tvariant row1, Tvariant row2 ->
       let row1 = row_repr row1 and row2 = row_repr row2 in
       begin match
@@ -1070,7 +1356,8 @@ let rec path_same_name p1 p2 =
 
 let type_same_name t1 t2 =
   match (repr t1).desc, (repr t2).desc with
-    Tconstr (p1, _, _), Tconstr (p2, _, _) -> path_same_name p1 p2
+    Tconstr (p1, _, _), Tconstr (p2, _, _) ->
+      path_same_name (fst (best_type_path p1)) (fst (best_type_path p2))
   | _ -> ()
 
 let rec trace_same_names = function
@@ -1087,7 +1374,7 @@ let unification_error unif tr txt1 ppf txt2 =
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
     try
-      let tr = filter_trace tr in
+      let tr = filter_trace (mis = None) tr in
       let t1, t1' = may_prepare_expansion (tr = []) t1
       and t2, t2' = may_prepare_expansion (tr = []) t2 in
       print_labels := not !Clflags.classic;
@@ -1107,28 +1394,55 @@ let unification_error unif tr txt1 ppf txt2 =
       print_labels := true;
       raise exn
 
-let report_unification_error ppf tr txt1 txt2 =
-  unification_error true tr txt1 ppf txt2;;
+let report_unification_error ppf env ?(unif=true)
+    tr txt1 txt2 =
+  wrap_printing_env env (fun () -> unification_error unif tr txt1 ppf txt2)
+;;
 
-let trace fst txt ppf tr =
+let trace fst keep_last txt ppf tr =
   print_labels := not !Clflags.classic;
   trace_same_names tr;
   try match tr with
     t1 :: t2 :: tr' ->
-      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr')
-      else trace fst txt ppf (filter_trace tr);
+      if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
+      else trace fst txt ppf (filter_trace keep_last tr);
       print_labels := true
   | _ -> ()
   with exn ->
     print_labels := true;
     raise exn
 
-let report_subtyping_error ppf tr1 txt1 tr2 =
-  reset ();
-  let tr1 = List.map prepare_expansion tr1
-  and tr2 = List.map prepare_expansion tr2 in
-  trace true txt1 ppf tr1;
-  if tr2 = [] then () else
-  let mis = mismatch true tr2 in
-  trace false "is not compatible with type" ppf tr2;
-  explanation true mis ppf
+let report_subtyping_error ppf env tr1 txt1 tr2 =
+  wrap_printing_env env (fun () ->
+    reset ();
+    let tr1 = List.map prepare_expansion tr1
+    and tr2 = List.map prepare_expansion tr2 in
+    fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1;
+    if tr2 = [] then fprintf ppf "@]" else
+    let mis = mismatch true tr2 in
+    fprintf ppf "%a%t@]"
+      (trace false (mis = None) "is not compatible with type") tr2
+      (explanation true mis))
+
+let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
+  wrap_printing_env env (fun () ->
+    reset ();
+    List.iter
+      (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
+      tpl;
+    match tpl with
+      [] -> assert false
+    | [tp, tp'] ->
+        fprintf ppf
+          "@[%t@;<1 2>%a@ \
+             %t@;<1 2>%a\
+           @]"
+          txt1 (type_path_expansion tp) tp'
+          txt3 (type_path_expansion tp0) tp0'
+    | _ ->
+        fprintf ppf
+          "@[%t@;<1 2>@[%a@]\
+             @ %t@;<1 2>%a\
+           @]"
+          txt2 type_path_list tpl
+          txt3 (type_path_expansion tp0) tp0')
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index f2865204..7fa00ff4 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printtyp.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
 (* Printing functions *)
 
 open Format
@@ -22,7 +20,13 @@ val longident: formatter -> Longident.t -> unit
 val ident: formatter -> Ident.t -> unit
 val tree_of_path: Path.t -> out_ident
 val path: formatter -> Path.t -> unit
+val string_of_path: Path.t -> string
 val raw_type_expr: formatter -> type_expr -> unit
+
+val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a
+    (* Call the function using the environment for type path shortening *)
+    (* This affects all the printing functions below *)
+
 val reset: unit -> unit
 val mark_loops: type_expr -> unit
 val reset_and_mark_loops: type_expr -> unit
@@ -62,15 +66,18 @@ val tree_of_cltype_declaration:
 val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
 val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
 val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
-val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit
-val unification_error:
-    bool -> (type_expr * type_expr) list ->
-    (formatter -> unit) -> formatter -> (formatter -> unit) ->
-    unit
+val trace:
+    bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit
 val report_unification_error:
-    formatter -> (type_expr * type_expr) list ->
+    formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
     (formatter -> unit) -> (formatter -> unit) ->
     unit
 val report_subtyping_error:
-    formatter -> (type_expr * type_expr) list ->
+    formatter -> Env.t -> (type_expr * type_expr) list ->
     string -> (type_expr * type_expr) list -> unit
+val report_ambiguous_type_error:
+    formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+    (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
+(* for toploop *)
+val hide_rec_items: signature_item list -> unit
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index d89d25b5..840a7673 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printast.ml 12414 2012-05-02 14:36:55Z lefessan $ *)
-
 open Asttypes;;
 open Format;;
 open Lexing;;
@@ -209,8 +207,8 @@ and pattern i ppf x =
   | Tpat_tuple (l) ->
       line i ppf "Ppat_tuple\n";
       list i pattern ppf l;
-  | Tpat_construct (li, _, _, po, explicity_arity) ->
-      line i ppf "Ppat_construct %a\n" fmt_path li;
+  | Tpat_construct (li, _, po, explicity_arity) ->
+      line i ppf "Ppat_construct %a\n" fmt_longident li;
       list i pattern ppf po;
       bool i ppf explicity_arity;
   | Tpat_variant (l, po, _) ->
@@ -236,8 +234,8 @@ and expression_extra i ppf x =
       line i ppf "Pexp_constraint\n";
       option i core_type ppf cto1;
       option i core_type ppf cto2;
-  | Texp_open (m, _, _) ->
-      line i ppf "Pexp_open \"%a\"\n" fmt_path m;
+  | Texp_open (ovf, m, _, _) ->
+      line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
   | Texp_poly cto ->
       line i ppf "Pexp_poly\n";
       option i core_type ppf cto;
@@ -277,8 +275,8 @@ and expression i ppf x =
   | Texp_tuple (l) ->
       line i ppf "Pexp_tuple\n";
       list i expression ppf l;
-  | Texp_construct (li, _, _, eo, b) ->
-      line i ppf "Pexp_construct %a\n" fmt_path li;
+  | Texp_construct (li, _, eo, b) ->
+      line i ppf "Pexp_construct %a\n" fmt_longident li;
       list i expression ppf eo;
       bool i ppf b;
   | Texp_variant (l, eo) ->
@@ -288,14 +286,14 @@ and expression i ppf x =
       line i ppf "Pexp_record\n";
       list i longident_x_expression ppf l;
       option i expression ppf eo;
-  | Texp_field (e, li, _, _) ->
+  | Texp_field (e, li, _) ->
       line i ppf "Pexp_field\n";
       expression i ppf e;
-      path i ppf li;
-  | Texp_setfield (e1, li, _, _, e2) ->
+      longident i ppf li;
+  | Texp_setfield (e1, li, _, e2) ->
       line i ppf "Pexp_setfield\n";
       expression i ppf e1;
-      path i ppf li;
+      longident i ppf li;
       expression i ppf e2;
   | Texp_array (l) ->
       line i ppf "Pexp_array\n";
@@ -581,7 +579,8 @@ and signature_item i ppf x =
   | Tsig_modtype (s, _, md) ->
       line i ppf "Psig_modtype \"%a\"\n" fmt_ident s;
       modtype_declaration i ppf md;
-  | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li;
+  | Tsig_open (ovf, li,_) ->
+    line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li;
   | Tsig_include (mt, _) ->
       line i ppf "Psig_include\n";
       module_type i ppf mt;
@@ -670,7 +669,8 @@ and structure_item i ppf x =
   | Tstr_modtype (s, _, mt) ->
       line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s;
       module_type i ppf mt;
-  | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li;
+  | Tstr_open (ovf, li, _) ->
+    line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li;
   | Tstr_class (l) ->
       line i ppf "Pstr_class\n";
       list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l);
@@ -716,8 +716,8 @@ and string_list_x_location i ppf (l, loc) =
   line i ppf " %a\n" fmt_location loc;
   list (i+1) string_loc ppf l;
 
-and longident_x_pattern i ppf (li, _, _, p) =
-  line i ppf "%a\n" fmt_path li;
+and longident_x_pattern i ppf (li, _, p) =
+  line i ppf "%a\n" fmt_longident li;
   pattern (i+1) ppf p;
 
 and pattern_x_expression_case i ppf (p, e) =
@@ -734,8 +734,8 @@ and string_x_expression i ppf (s, _, e) =
   line i ppf " \"%a\"\n" fmt_path s;
   expression (i+1) ppf e;
 
-and longident_x_expression i ppf (li, _, _, e) =
-  line i ppf "%a\n" fmt_path li;
+and longident_x_expression i ppf (li, _, e) =
+  line i ppf "%a\n" fmt_longident li;
   expression (i+1) ppf e;
 
 and label_x_expression i ppf (l, e, _) =
@@ -759,3 +759,5 @@ and label_x_bool_x_core_type_list i ppf x =
 let interface ppf x = list 0 signature_item ppf x.sig_items;;
 
 let implementation ppf x = list 0 structure_item ppf x.str_items;;
+
+let implementation_with_coercion ppf (x, _) = implementation ppf x
diff --git a/typing/printtyped.mli b/typing/printtyped.mli
index 7bb594aa..b2f1e3f7 100644
--- a/typing/printtyped.mli
+++ b/typing/printtyped.mli
@@ -10,10 +10,11 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: printast.mli 12404 2012-04-26 13:20:09Z lefessan $ *)
-
 open Typedtree;;
 open Format;;
 
 val interface : formatter -> signature -> unit;;
 val implementation : formatter -> structure -> unit;;
+
+val implementation_with_coercion :
+    formatter -> (structure * module_coercion) -> unit;;
diff --git a/typing/stypes.ml b/typing/stypes.ml
index 26a5a5e0..e1f4557a 100644
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stypes.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Recording and dumping (partial) type information *)
 
 (*
@@ -22,11 +20,12 @@
 *)
 
 open Annot;;
-open Format;;
 open Lexing;;
 open Location;;
 open Typedtree;;
 
+let output_int oc i = output_string oc (string_of_int i)
+
 type annotation =
   | Ti_pat   of pattern
   | Ti_expr  of expression
@@ -73,15 +72,22 @@ let cmp_ti_inner_first ti1 ti2 =
 
 let print_position pp pos =
   if pos = dummy_pos then
-    fprintf pp "--"
-  else
-    fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol
-                             pos.pos_cnum;
+    output_string pp "--"
+  else begin
+    output_char pp '\"';
+    output_string pp (String.escaped pos.pos_fname);
+    output_string pp "\" ";
+    output_int pp pos.pos_lnum;
+    output_char pp ' ';
+    output_int pp pos.pos_bol;
+    output_char pp ' ';
+    output_int pp pos.pos_cnum;
+  end
 ;;
 
 let print_location pp loc =
   print_position pp loc.loc_start;
-  fprintf pp " ";
+  output_char pp ' ';
   print_position pp loc.loc_end;
 ;;
 
@@ -117,9 +123,22 @@ let call_kind_string k =
 
 let print_ident_annot pp str k =
   match k with
-  | Idef l -> fprintf pp "def %s %a@." str print_location l;
-  | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l;
-  | Iref_external -> fprintf pp "ext_ref %s@." str;
+  | Idef l ->
+      output_string pp "def ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_internal l ->
+      output_string pp "int_ref ";
+      output_string pp str;
+      output_char pp ' ';
+      print_location pp l;
+      output_char pp '\n'
+  | Iref_external ->
+      output_string pp "ext_ref ";
+      output_string pp str;
+      output_char pp '\n'
 ;;
 
 (* The format of the annotation file is documented in emacs/caml-types.el. *)
@@ -127,24 +146,40 @@ let print_ident_annot pp str k =
 let print_info pp prev_loc ti =
   match ti with
   | Ti_class _ | Ti_mod _ -> prev_loc
-  | Ti_pat  {pat_loc = loc; pat_type = typ}
-  | Ti_expr {exp_loc = loc; exp_type = typ} ->
-      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
-      fprintf pp "type(@.  ";
+  | Ti_pat  {pat_loc = loc; pat_type = typ; pat_env = env}
+  | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} ->
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "type(\n";
       printtyp_reset_maybe loc;
       Printtyp.mark_loops typ;
-      Printtyp.type_sch pp typ;
-      fprintf pp "@.)@.";
+      Format.pp_print_string Format.str_formatter "  ";
+      Printtyp.wrap_printing_env env
+                       (fun () -> Printtyp.type_sch Format.str_formatter typ);
+      Format.pp_print_newline Format.str_formatter ();
+      let s = Format.flush_str_formatter () in
+      output_string pp s;
+      output_string pp ")\n";
       loc
   | An_call (loc, k) ->
-      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
-      fprintf pp "call(@.  %s@.)@." (call_kind_string k);
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "call(\n  ";
+      output_string pp (call_kind_string k);
+      output_string pp "\n)\n";
       loc
   | An_ident (loc, str, k) ->
-      if loc <> prev_loc then fprintf pp "%a@." print_location loc;
-      fprintf pp "ident(@.  ";
+      if loc <> prev_loc then begin
+        print_location pp loc;
+        output_char pp '\n'
+      end;
+      output_string pp "ident(\n  ";
       print_ident_annot pp str k;
-      fprintf pp ")@.";
+      output_string pp ")\n";
       loc
 ;;
 
@@ -159,8 +194,8 @@ let dump filename =
     let info = get_info () in
     let pp =
       match filename with
-          None -> std_formatter
-        | Some filename -> formatter_of_out_channel (open_out filename) in
+          None -> stdout
+        | Some filename -> open_out filename in
     sort_filter_phrases ();
     ignore (List.fold_left (print_info pp) Location.none info);
     phrases := [];
diff --git a/typing/stypes.mli b/typing/stypes.mli
index 305402af..02a467f5 100644
--- a/typing/stypes.mli
+++ b/typing/stypes.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: stypes.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Recording and dumping (partial) type information *)
 
 (* Clflags.save_types must be true *)
diff --git a/typing/subst.ml b/typing/subst.ml
index f0a2ecfc..a8d25fb1 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: subst.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Substitutions *)
 
 open Misc
@@ -45,7 +43,7 @@ let rec module_path s = function
   | Papply(p1, p2) ->
       Papply(module_path s p1, module_path s p2)
 
-let rec modtype_path s = function
+let modtype_path s = function
     Pident id as p ->
       begin try
         match Tbl.find id s.modtypes with
diff --git a/typing/subst.mli b/typing/subst.mli
index a50831dc..18d22ff3 100644
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: subst.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Substitutions *)
 
 open Types
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c7f81b18..db5bbde5 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -10,9 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typeclass.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
-open Misc
 open Parsetree
 open Asttypes
 open Path
@@ -48,6 +45,9 @@ type error =
   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
   | No_overriding of string * string
+  | Duplicate of string * string
+
+exception Error of Location.t * Env.t * error
 
 open Typedtree
 
@@ -59,8 +59,6 @@ let mkcf desc loc = { cf_desc = desc; cf_loc = loc }
 let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc }
 
 
-exception Error of Location.t * error
-
 
                        (**********************)
                        (*  Useful constants  *)
@@ -92,18 +90,22 @@ let rec scrape_class_type =
   | cty                     -> cty
 
 (* Generalize a class type *)
-let rec generalize_class_type =
+let rec generalize_class_type gen =
   function
     Cty_constr (_, params, cty) ->
-      List.iter Ctype.generalize params;
-      generalize_class_type cty
+      List.iter gen params;
+      generalize_class_type gen cty
   | Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
-      Ctype.generalize sty;
-      Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
-      List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
+      gen sty;
+      Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
+      List.iter (fun (_,tl) -> List.iter gen tl) inher
   | Cty_fun (_, ty, cty) ->
-      Ctype.generalize ty;
-      generalize_class_type cty
+      gen ty;
+      generalize_class_type gen cty
+
+let generalize_class_type vars =
+  let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
+  generalize_class_type gen
 
 (* Return the virtual methods of a class type *)
 let virtual_methods sign =
@@ -134,7 +136,7 @@ let rec class_body cty =
   | Cty_fun (_, ty, cty) ->
       class_body cty
 
-let rec extract_constraints cty =
+let extract_constraints cty =
   let sign = Ctype.signature_of_class_type cty in
   (Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [],
    begin let (fields, _) =
@@ -219,13 +221,15 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
   let (id, virt) =
     try
       let (id, mut', virt', ty') = Vars.find lab !vars in
-      if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
+      if mut' <> mut then
+        raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
       Ctype.unify val_env (instance ty) (instance ty');
       (if not inh then Some id else None),
       (if virt' = Concrete then virt' else virt)
     with
       Ctype.Unify tr ->
-        raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
+        raise (Error(loc, val_env,
+                     Field_type_mismatch("instance variable", lab, tr)))
     | Not_found -> None, virt
   in
   let (id, _, _, _) as result =
@@ -252,7 +256,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent =
       with Ctype.Unify trace ->
         match trace with
           _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
-            raise(Error(loc, Field_type_mismatch ("method", n, rem)))
+            raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
         | _ ->
             assert false
       end;
@@ -277,7 +281,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent =
                  (cname :: Concr.elements over_vals));
       | Some Override
         when Concr.is_empty over_meths && Concr.is_empty over_vals ->
-        raise (Error(loc, No_overriding ("","")))
+        raise (Error(loc, env, No_overriding ("","")))
       | _ -> ()
       end;
 
@@ -287,7 +291,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent =
       (cl_sig, concr_meths, warn_vals)
 
   | _ ->
-      raise(Error(loc, Structure_expected parent))
+      raise(Error(loc, env, Structure_expected parent))
 
 let virtual_method val_env meths self_type lab priv sty loc =
   let (_, ty') =
@@ -297,7 +301,7 @@ let virtual_method val_env meths self_type lab priv sty loc =
   let ty = cty.ctyp_type in
   begin
     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-        raise(Error(loc, Field_type_mismatch ("method", lab, trace)));
+        raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
   end;
   cty
 
@@ -309,7 +313,7 @@ let declare_method val_env meths self_type lab priv sty loc =
   in
   let unif ty =
     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-      raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+      raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
   in
   match sty.ptyp_desc, priv with
     Ptyp_poly ([],sty'), Public ->
@@ -339,7 +343,7 @@ let type_constraint val_env sty sty' loc =
   let ty' = cty'.ctyp_type in
   begin
     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-        raise(Error(loc, Unconsistent_constraint trace));
+        raise(Error(loc, val_env, Unconsistent_constraint trace));
   end;
   (cty, cty')
 
@@ -423,7 +427,7 @@ and class_signature env sty sign loc =
   begin try
     Ctype.unify env self_type dummy_obj
   with Ctype.Unify _ ->
-    raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
+    raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
   end;
 
   (* Class type fields *)
@@ -449,12 +453,12 @@ and class_type env scty =
     Pcty_constr (lid, styl) ->
       let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in
       if Path.same decl.clty_path unbound_class then
-        raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt));
+        raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
       let (params, clty) =
         Ctype.instance_class decl.clty_params decl.clty_type
       in
       if List.length params <> List.length styl then
-        raise(Error(scty.pcty_loc,
+        raise(Error(scty.pcty_loc, env,
                     Parameter_arity_mismatch (lid.txt, List.length params,
                                                    List.length styl)));
       let ctys = List.map2
@@ -463,7 +467,7 @@ and class_type env scty =
           let ty' = cty'.ctyp_type in
           begin
            try Ctype.unify env ty' ty with Ctype.Unify trace ->
-                  raise(Error(sty.ptyp_loc, Parameter_mismatch trace))
+                  raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
             end;
             cty'
         )       styl params
@@ -494,7 +498,8 @@ let class_type env scty =
 (*******************************)
 
 let rec class_field self_loc cl_num self_type meths vars
-    (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
+    (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
+     local_meths, local_vals)
   cf =
   let loc = cf.pcf_loc in
   match cf.pcf_desc with
@@ -542,7 +547,7 @@ let rec class_field self_loc cl_num self_type meths vars
       (val_env, met_env, par_env,
        lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc)
        :: fields,
-       concr_meths, warn_vals, inher)
+       concr_meths, warn_vals, inher, local_meths, local_vals)
 
   | Pcf_valvirt (lab, mut, styp) ->
       if !Clflags.principal then Ctype.begin_def ();
@@ -560,21 +565,24 @@ let rec class_field self_loc cl_num self_type meths vars
        lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty,
                             met_env' == met_env)) loc)
        :: fields,
-       concr_meths, warn_vals, inher)
+       concr_meths, warn_vals, inher, local_meths, local_vals)
 
   | Pcf_val (lab, mut, ovf, sexp) ->
+      if Concr.mem lab.txt local_vals then
+        raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
       if Concr.mem lab.txt warn_vals then begin
         if ovf = Fresh then
           Location.prerr_warning lab.loc
             (Warnings.Instance_variable_override[lab.txt])
       end else begin
         if ovf = Override then
-          raise(Error(loc, No_overriding ("instance variable", lab.txt)))
+          raise(Error(loc, val_env,
+                      No_overriding ("instance variable", lab.txt)))
       end;
       if !Clflags.principal then Ctype.begin_def ();
       let exp =
         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
-          raise(Error(loc, Make_nongen_seltype ty))
+          raise(Error(loc, val_env, Make_nongen_seltype ty))
       in
       if !Clflags.principal then begin
         Ctype.end_def ();
@@ -588,22 +596,25 @@ let rec class_field self_loc cl_num self_type meths vars
        lazy (mkcf (Tcf_val (lab.txt, lab, mut, id,
                             Tcfk_concrete exp, met_env' == met_env)) loc)
        :: fields,
-       concr_meths, Concr.add lab.txt warn_vals, inher)
+       concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
+       Concr.add lab.txt local_vals)
 
   | Pcf_virt (lab, priv, sty) ->
       let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
       (val_env, met_env, par_env,
         lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc)
        ::fields,
-        concr_meths, warn_vals, inher)
+        concr_meths, warn_vals, inher, local_meths, local_vals)
 
   | Pcf_meth (lab, priv, ovf, expr)  ->
+      if Concr.mem lab.txt local_meths then
+        raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
       if Concr.mem lab.txt concr_meths then begin
         if ovf = Fresh then
           Location.prerr_warning loc (Warnings.Method_override [lab.txt])
       end else begin
         if ovf = Override then
-          raise(Error(loc, No_overriding("method", lab.txt)))
+          raise(Error(loc, val_env, No_overriding("method", lab.txt)))
       end;
       let (_, ty) =
         Ctype.filter_self_method val_env lab.txt priv meths self_type
@@ -629,7 +640,8 @@ let rec class_field self_loc cl_num self_type meths vars
           end
       | _ -> assert false
       with Ctype.Unify trace ->
-        raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace)))
+        raise(Error(loc, val_env,
+                    Field_type_mismatch ("method", lab.txt, trace)))
       end;
       let meth_expr = make_method self_loc cl_num expr in
       (* backup variables for Pexp_override *)
@@ -649,13 +661,14 @@ let rec class_field self_loc cl_num self_type meths vars
               | Fresh -> false)) loc
         end in
       (val_env, met_env, par_env, field::fields,
-       Concr.add lab.txt concr_meths, warn_vals, inher)
+       Concr.add lab.txt concr_meths, warn_vals, inher,
+       Concr.add lab.txt local_meths, local_vals)
 
   | Pcf_constr (sty, sty') ->
       let (cty, cty') = type_constraint val_env sty sty' loc in
       (val_env, met_env, par_env,
         lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields,
-        concr_meths, warn_vals, inher)
+        concr_meths, warn_vals, inher, local_meths, local_vals)
 
   | Pcf_init expr ->
       let expr = make_method self_loc cl_num expr in
@@ -672,7 +685,8 @@ let rec class_field self_loc cl_num self_type meths vars
           Ctype.end_def ();
           mkcf (Tcf_init texp) loc
         end in
-      (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher)
+      (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
+       inher, local_meths, local_vals)
 
 and class_structure cl_num final val_env met_env loc
   { pcstr_pat = spat; pcstr_fields = str } =
@@ -703,7 +717,7 @@ and class_structure cl_num final val_env met_env loc
     else self_type in
   begin try Ctype.unify val_env public_self ty with
     Ctype.Unify _ ->
-      raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
+      raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
   end;
   let get_methods ty =
     (fst (Ctype.flatten_fields
@@ -721,9 +735,10 @@ and class_structure cl_num final val_env met_env loc
   end;
 
   (* Typing of class fields *)
-  let (_, _, _, fields, concr_meths, _, inher) =
+  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, [])
+      (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
+       Concr.empty, Concr.empty)
       str
   in
   Ctype.unify val_env self_type (Ctype.newvar ());
@@ -746,7 +761,7 @@ and class_structure cl_num final val_env met_env loc
         (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
         sign.cty_vars [] in
     if mets <> [] || vals <> [] then
-      raise(Error(loc, Virtual_class(true, mets, vals)));
+      raise(Error(loc, val_env, Virtual_class(true, mets, vals)));
     let self_methods =
       List.fold_right
         (fun (lab,kind,ty) rem ->
@@ -762,7 +777,7 @@ and class_structure cl_num final val_env met_env loc
       Ctype.unify val_env private_self
         (Ctype.newty (Tobject(self_methods, ref None)));
       Ctype.unify val_env public_self self_type
-    with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
+    with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
     end;
   end;
 
@@ -797,7 +812,7 @@ and class_expr cl_num val_env met_env scl =
     Pcl_constr (lid, styl) ->
       let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
       if Path.same decl.cty_path unbound_class then
-        raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt));
+        raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
       let tyl = List.map
           (fun sty -> transl_simple_type val_env false sty)
           styl
@@ -807,14 +822,14 @@ and class_expr cl_num val_env met_env scl =
       in
       let clty' = abbreviate_class_type path params clty in
       if List.length params <> List.length tyl then
-        raise(Error(scl.pcl_loc,
+        raise(Error(scl.pcl_loc, val_env,
                     Parameter_arity_mismatch (lid.txt, List.length params,
                                                    List.length tyl)));
       List.iter2
         (fun cty' ty ->
           let ty' = cty'.ctyp_type in
            try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
-             raise(Error(cty'.ctyp_loc, Parameter_mismatch trace)))
+             raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
         tyl params;
       let cl =
         rc {cl_desc = Tcl_ident (path, lid, tyl);
@@ -884,7 +899,7 @@ and class_expr cl_num val_env met_env scl =
           end
           pv
       in
-      let rec not_function = function
+      let not_function = function
           Cty_fun _ -> false
         | _ -> true
       in
@@ -908,7 +923,12 @@ and class_expr cl_num val_env met_env scl =
             (l, Ctype.instance_def pat.pat_type, cl.cl_type);
           cl_env = val_env}
   | Pcl_apply (scl', sargs) ->
+      if !Clflags.principal then Ctype.begin_def ();
       let cl = class_expr cl_num val_env met_env scl' in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        generalize_class_type false cl.cl_type;
+      end;
       let rec nonopt_labels ls ty_fun =
         match ty_fun with
         | Cty_fun (l, _, ty_res) ->
@@ -927,9 +947,10 @@ and class_expr cl_num val_env met_env scl =
           true
         end
       in
-      let rec type_args args omitted ty_fun sargs more_sargs =
-        match ty_fun with
-        | Cty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] ->
+      let rec type_args args omitted ty_fun ty_fun0 sargs more_sargs =
+        match ty_fun, ty_fun0 with
+        | Cty_fun (l, ty, ty_fun), Cty_fun (_, ty0, ty_fun0)
+          when sargs <> [] || more_sargs <> [] ->
             let name = Btype.label_name l
             and optional =
               if Btype.is_optional l then Optional else Required in
@@ -937,12 +958,13 @@ and class_expr cl_num val_env met_env scl =
               if ignore_labels && not (Btype.is_optional l) then begin
                 match sargs, more_sargs with
                   (l', sarg0)::_, _ ->
-                    raise(Error(sarg0.pexp_loc, Apply_wrong_label(l')))
+                    raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l'))
                 | _, (l', sarg0)::more_sargs ->
                     if l <> l' && l' <> "" then
-                      raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
+                      raise(Error(sarg0.pexp_loc, val_env,
+                                  Apply_wrong_label l'))
                     else ([], more_sargs,
-                          Some (type_argument val_env sarg0 ty ty))
+                          Some (type_argument val_env sarg0 ty ty0))
                 | _ ->
                     assert false
               end else try
@@ -956,41 +978,47 @@ and class_expr cl_num val_env met_env scl =
                       Btype.extract_label name more_sargs
                     in (l', sarg0, sargs @ sargs1, sargs2)
                 in
+                if optional = Required && Btype.is_optional l' then
+                  Location.prerr_warning sarg0.pexp_loc
+                    (Warnings.Nonoptional_label l);
                 sargs, more_sargs,
-                if Btype.is_optional l' || not (Btype.is_optional l) then
-                  Some (type_argument val_env sarg0 ty ty)
+                if optional = Required || Btype.is_optional l' then
+                  Some (type_argument val_env sarg0 ty ty0)
                 else
-                  let ty0 = extract_option_type val_env ty in
-                  let arg = type_argument val_env sarg0 ty0 ty0 in
+                  let ty' = extract_option_type val_env ty
+                  and ty0' = extract_option_type val_env ty0 in
+                  let arg = type_argument val_env sarg0 ty' ty0' in
                   Some (option_some arg)
               with Not_found ->
                 sargs, more_sargs,
                 if Btype.is_optional l &&
                   (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
                 then
-                  Some (option_none ty Location.none)
+                  Some (option_none ty0 Location.none)
                 else None
             in
-            let omitted = if arg = None then (l,ty) :: omitted else omitted in
-            type_args ((l,arg,optional)::args) omitted ty_fun sargs more_sargs
+            let omitted = if arg = None then (l,ty0) :: omitted else omitted in
+            type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0
+              sargs more_sargs
         | _ ->
             match sargs @ more_sargs with
               (l, sarg0)::_ ->
                 if omitted <> [] then
-                  raise(Error(sarg0.pexp_loc, Apply_wrong_label l))
+                  raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
                 else
-                  raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
+                  raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
             | [] ->
                 (List.rev args,
                  List.fold_left
                    (fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun))
-                   ty_fun omitted)
+                   ty_fun0 omitted)
       in
       let (args, cty) =
+        let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
         if ignore_labels then
-          type_args [] [] cl.cl_type [] sargs
+          type_args [] [] cl.cl_type ty_fun0 [] sargs
         else
-          type_args [] [] cl.cl_type sargs []
+          type_args [] [] cl.cl_type ty_fun0 sargs []
       in
       rc {cl_desc = Tcl_apply (cl, args);
           cl_loc = scl.pcl_loc;
@@ -1001,7 +1029,7 @@ and class_expr cl_num val_env met_env scl =
         try
           Typecore.type_let val_env rec_flag sdefs None
         with Ctype.Unify [(ty, _)] ->
-          raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
+          raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty))
       in
       let (vals, met_env) =
         List.fold_right
@@ -1057,7 +1085,7 @@ and class_expr cl_num val_env met_env scl =
         Includeclass.class_types val_env cl.cl_type clty.cltyp_type
       with
         []    -> ()
-      | error -> raise(Error(cl.cl_loc, Class_match_failure error))
+      | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
       end;
       let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
       rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
@@ -1098,7 +1126,7 @@ let rec approx_description ct =
 
 let temp_abbrev loc env id arity =
   let params = ref [] in
-  for i = 1 to arity do
+  for _i = 1 to arity do
     params := Ctype.newvar () :: !params
   done;
   let ty = Ctype.newobj (Ctype.newvar ()) in
@@ -1109,7 +1137,7 @@ let temp_abbrev loc env id arity =
        type_kind = Type_abstract;
        type_private = Public;
        type_manifest = Some ty;
-       type_variance = List.map (fun _ -> true, true, true) !params;
+       type_variance = Misc.replicate_list Variance.full arity;
        type_newtype_level = None;
        type_loc = loc;
       }
@@ -1117,7 +1145,7 @@ let temp_abbrev loc env id arity =
   in
   (!params, ty, env)
 
-let rec initial_env define_class approx
+let initial_env define_class approx
     (res, env) (cl, id, ty_id, obj_id, cl_id) =
   (* Temporary abbreviations *)
   let arity = List.length (fst cl.pci_params) in
@@ -1177,7 +1205,7 @@ let class_infos define_class kind
       let params, loc = cl.pci_params in
       List.map (fun x -> enter_type_variable true loc x.txt) params
     with Already_bound ->
-      raise(Error(snd cl.pci_params, Repeated_parameter))
+      raise(Error(snd cl.pci_params, env, Repeated_parameter))
   in
 
   (* Allow self coercions (only for class declarations) *)
@@ -1198,8 +1226,11 @@ let class_infos define_class kind
   Ctype.end_def ();
 
   let sty = Ctype.self_type typ in
-  ignore (Ctype.object_fields sty);
 
+  (* First generalize the type of the dummy method (cf PR#6123) *)
+  let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
+  List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
+    fields;
   (* Generalize the row variable *)
   let rv = Ctype.row_variable sty in
   List.iter (Ctype.limited_generalize rv) params;
@@ -1215,7 +1246,7 @@ let class_infos define_class kind
     begin try
       List.iter2 (Ctype.unify env) obj_params obj_params'
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(cl.pci_loc, env,
             Bad_parameters (obj_id, constr,
                             Ctype.newconstr (Path.Pident obj_id)
                                             obj_params')))
@@ -1223,7 +1254,7 @@ let class_infos define_class kind
     begin try
       Ctype.unify env ty constr
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(cl.pci_loc, env,
         Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
     end
   end;
@@ -1237,7 +1268,7 @@ let class_infos define_class kind
     begin try
       List.iter2 (Ctype.unify env) cl_params cl_params'
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(cl.pci_loc, env,
             Bad_parameters (cl_id,
                             Ctype.newconstr (Path.Pident cl_id)
                                             cl_params,
@@ -1248,7 +1279,7 @@ let class_infos define_class kind
       Ctype.unify env ty cl_ty
     with Ctype.Unify _ ->
       let constr = Ctype.newconstr (Path.Pident cl_id) params in
-      raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
+      raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))
     end
   end;
 
@@ -1258,12 +1289,12 @@ let class_infos define_class kind
       (constructor_type constr obj_type)
       (Ctype.instance env constr_type)
   with Ctype.Unify trace ->
-    raise(Error(cl.pci_loc,
+    raise(Error(cl.pci_loc, env,
                 Constructor_type_mismatch (cl.pci_name.txt, trace)))
   end;
 
   (* Class and class type temporary definitions *)
-  let cty_variance = List.map (fun _ -> true, true) params in
+  let cty_variance = List.map (fun _ -> Variance.full) params in
   let cltydef =
     {clty_params = params; clty_type = class_body typ;
      clty_variance = cty_variance;
@@ -1291,7 +1322,7 @@ let class_infos define_class kind
         (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
         sign.cty_vars [] in
     if mets <> []  || vals <> [] then
-      raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
+      raise(Error(cl.pci_loc, env, Virtual_class(true, mets, vals)));
   end;
 
   (* Misc. *)
@@ -1324,7 +1355,7 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some obj_ty;
-     type_variance = List.map (fun _ -> true, true, true) obj_params;
+     type_variance = List.map (fun _ -> Variance.full) obj_params;
      type_newtype_level = None;
      type_loc = cl.pci_loc}
   in
@@ -1339,7 +1370,7 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some cl_ty;
-     type_variance = List.map (fun _ -> true, true, true) cl_params;
+     type_variance = List.map (fun _ -> Variance.full) cl_params;
      type_newtype_level = None;
      type_loc = cl.pci_loc}
   in
@@ -1353,28 +1384,19 @@ let final_decl env define_class
 
   begin try Ctype.collapse_conj_params env clty.cty_params
   with Ctype.Unify trace ->
-    raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace)))
+    raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
   end;
 
   List.iter Ctype.generalize clty.cty_params;
-  generalize_class_type clty.cty_type;
-  begin match clty.cty_new with
-    None -> ()
-  | Some ty -> Ctype.generalize ty
-  end;
+  generalize_class_type true clty.cty_type;
+  Misc.may  Ctype.generalize clty.cty_new;
   List.iter Ctype.generalize obj_abbr.type_params;
-  begin match obj_abbr.type_manifest with
-    None    -> ()
-  | Some ty -> Ctype.generalize ty
-  end;
+  Misc.may  Ctype.generalize obj_abbr.type_manifest;
   List.iter Ctype.generalize cl_abbr.type_params;
-  begin match cl_abbr.type_manifest with
-    None    -> ()
-  | Some ty -> Ctype.generalize ty
-  end;
+  Misc.may  Ctype.generalize cl_abbr.type_manifest;
 
   if not (closed_class clty) then
-    raise(Error(cl.pci_loc, Non_generalizable_class (id, clty)));
+    raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
 
   begin match
     Ctype.closed_class clty.cty_params
@@ -1387,7 +1409,7 @@ let final_decl env define_class
         then function ppf -> Printtyp.class_declaration id ppf clty
         else function ppf -> Printtyp.cltype_declaration id ppf cltydef
       in
-      raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
+      raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
   end;
 
   (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
@@ -1450,10 +1472,10 @@ let check_coercions env
       in
       begin try Ctype.subtype env cl_ty obj_ty ()
       with Ctype.Subtype (tr1, tr2) ->
-        raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2)))
+        raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
       end;
       if not (Ctype.opened_object cl_ty) then
-        raise(Error(loc, Cannot_coerce_self obj_ty))
+        raise(Error(loc, env, Cannot_coerce_self obj_ty))
   end;
   (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
    arity, pub_meths, req)
@@ -1571,16 +1593,16 @@ let approx_class_declarations env sdecls =
 
 open Format
 
-let report_error ppf = function
+let report_error env ppf = function
   | Repeated_parameter ->
       fprintf ppf "A type parameter occurs several times"
   | Unconsistent_constraint trace ->
       fprintf ppf "The class constraints are not consistent.@.";
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (fun ppf -> fprintf ppf "Type")
         (fun ppf -> fprintf ppf "is not compatible with type")
   | Field_type_mismatch (k, m, trace) ->
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "The %s %s@ has type" k m)
         (function ppf ->
@@ -1619,7 +1641,7 @@ let report_error ppf = function
        Printtyp.type_expr actual
        Printtyp.type_expr expected
   | Constructor_type_mismatch (c, trace) ->
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "The expression \"new %s\" has type" c)
         (function ppf ->
@@ -1644,7 +1666,7 @@ let report_error ppf = function
            but is here applied to %i type argument(s)@]"
         Printtyp.longident lid expected provided
   | Parameter_mismatch trace ->
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "The type parameter")
         (function ppf ->
@@ -1701,11 +1723,11 @@ let report_error ppf = function
         "@[The type of this class,@ %a,@ \
            contains non-collapsible conjunctive types in constraints@]"
         (Printtyp.class_declaration id) clty;
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (fun ppf -> fprintf ppf "Type")
         (fun ppf -> fprintf ppf "is not compatible with type")
   | Final_self_clash trace ->
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "This object is expected to have type")
         (function ppf ->
@@ -1722,3 +1744,9 @@ let report_error ppf = function
         "instance variable"
   | No_overriding (kind, name) ->
       fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+  | Duplicate (kind, name) ->
+      fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
+                    kind name
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index cf4f2142..8ad20388 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typeclass.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 open Asttypes
 open Types
 open Format
@@ -105,7 +103,8 @@ type error =
   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
   | No_overriding of string * string
+  | Duplicate of string * string
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
-val report_error : formatter -> error -> unit
+val report_error : Env.t -> formatter -> error -> unit
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 94e4d9c9..2964f3fd 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typecore.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Typechecking for the core language *)
 
 open Misc
@@ -32,9 +30,12 @@ type error =
   | Expr_type_clash of (type_expr * type_expr) list
   | Apply_non_function of type_expr
   | Apply_wrong_label of label * type_expr
-  | Label_multiply_defined of Longident.t
+  | Label_multiply_defined of string
   | Label_missing of Ident.t list
   | Label_not_mutable of Longident.t
+  | Wrong_name of string * Path.t * Longident.t
+  | Name_type_mismatch of
+      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
   | Incomplete_format of string
   | Bad_conversion of string * int * char
   | Undefined_method of type_expr * string
@@ -61,8 +62,9 @@ type error =
   | Not_a_packed_module of type_expr
   | Recursive_local_constraint of (type_expr * type_expr) list
   | Unexpected_existential
+  | Unqualified_gadt_pattern of Path.t * string
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 
@@ -105,7 +107,6 @@ let rp node =
 
 
 let snd3 (_,x,_) = x
-let thd4 (_,_, x,_) = x
 
 (* Upper approximation of free identifiers on the parse tree *)
 
@@ -130,7 +131,7 @@ let iter_expression f e =
     | Pexp_variant (_, eo) -> may expr eo
     | Pexp_record (iel, eo) ->
         may expr eo; List.iter (fun (_, e) -> expr e) iel
-    | Pexp_open (_, e)
+    | Pexp_open (_, _, e)
     | Pexp_newtype (_, e)
     | Pexp_poly (e, _)
     | Pexp_lazy e
@@ -229,14 +230,14 @@ let mkexp exp_desc exp_type exp_loc exp_env =
 
 let option_none ty loc =
   let lid = Longident.Lident "None" in
-  let (path, cnone) = Env.lookup_constructor lid Env.initial in
-  mkexp (Texp_construct( path, mknoloc lid, cnone, [], false))
+  let cnone = Env.lookup_constructor lid Env.initial in
+  mkexp (Texp_construct(mknoloc lid, cnone, [], false))
     ty loc Env.initial
 
 let option_some texp =
   let lid = Longident.Lident "Some" in
-  let (path, csome) = Env.lookup_constructor lid Env.initial in
-  mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) )
+  let csome = Env.lookup_constructor lid Env.initial in
+  mkexp ( Texp_construct(mknoloc lid , csome, [texp],false) )
     (type_option texp.exp_type) texp.exp_loc texp.exp_env
 
 let extract_option_type env ty =
@@ -244,20 +245,23 @@ let extract_option_type env ty =
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
-let rec extract_label_names sexp env ty =
-  let ty = expand_head env ty in
-  match ty.desc with
-  | Tconstr (path, _, _) ->
-      let td = Env.find_type path env in
-      begin match td.type_kind with
-      | Type_record (fields, _) ->
-          List.map (fun (name, _, _) -> name) fields
-      | Type_abstract when td.type_manifest <> None ->
-          extract_label_names sexp env (expand_head env ty)
-      | _ -> assert false
-      end
-  | _ ->
-      assert false
+let extract_concrete_record env ty =
+  match extract_concrete_typedecl env ty with
+    (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+  | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+  match extract_concrete_typedecl env ty with
+    (* exclude exceptions *)
+    (p0, p, {type_kind=Type_variant (_::_ as cstrs)}) -> (p0, p, cstrs)
+  | _ -> raise Not_found
+
+let extract_label_names sexp env ty =
+  try
+    let (_, _,fields) = extract_concrete_record env ty in
+    List.map (fun (name, _, _) -> name) fields
+  with Not_found ->
+    assert false
 
 (* Typing of patterns *)
 
@@ -267,9 +271,9 @@ let unify_pat_types loc env ty ty' =
     unify env ty ty'
   with
     Unify trace ->
-      raise(Error(loc, Pattern_type_clash(trace)))
+      raise(Error(loc, env, Pattern_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
 
 (* unification inside type_exp and type_expect *)
 let unify_exp_types loc env ty expected_ty =
@@ -279,9 +283,9 @@ let unify_exp_types loc env ty expected_ty =
     unify env ty expected_ty
   with
     Unify trace ->
-      raise(Error(loc, Expr_type_clash(trace)))
+      raise(Error(loc, env, Expr_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
 
 (* level at which to create the local type declarations *)
 let newtype_level = ref None
@@ -300,11 +304,11 @@ let unify_pat_types_gadt loc env ty ty' =
     unify_gadt ~newtype_level env ty ty'
   with
     Unify trace ->
-      raise(Error(loc, Pattern_type_clash(trace)))
+      raise(Error(loc, !env, Pattern_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
   | Unification_recursive_abbrev trace ->
-      raise(Error(loc, Recursive_local_constraint trace))
+      raise(Error(loc, !env, Recursive_local_constraint trace))
 
 
 (* Creating new conjunctive types is not allowed when typing patterns *)
@@ -322,7 +326,7 @@ let finalize_variant pat =
         | _ -> assert false
       in
       begin match row_field tag row with
-      | Rabsent -> assert false
+      | Rabsent -> () (* assert false *)
       | Reither (true, [], _, e) when not row.row_closed ->
           set_row_field e (Rpresent None)
       | Reither (false, ty::tl, _, e) when not row.row_closed ->
@@ -371,13 +375,14 @@ let reset_pattern scope allow =
 let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
   if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt)
       !pattern_variables
-  then raise(Error(loc, Multiply_bound_variable name.txt));
+  then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
   let id = Ident.create name.txt in
   pattern_variables :=
     (id, ty, name, loc, is_as_variable) :: !pattern_variables;
   if is_module then begin
     (* Note: unpack patterns enter a variable of the same name *)
-    if not !allow_modules then raise (Error (loc, Modules_not_allowed));
+    if not !allow_modules then
+      raise (Error (loc, Env.empty, Modules_not_allowed));
     module_variables := (name, loc) :: !module_variables
   end else
     (* moved to genannot *)
@@ -406,18 +411,18 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
               unify env t1 t2
             with
             | Unify trace ->
-                raise(Error(loc, Pattern_type_clash(trace)))
+                raise(Error(loc, env, Pattern_type_clash(trace)))
             end;
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_,_,_,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x))
+      | [],(x,_,_,_,_)::_  -> raise (Error (loc, env, Orpat_vars x))
       | (x,_,_,_,_)::_, (y,_,_,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
-          raise (Error (loc, Orpat_vars min_var)) in
+          raise (Error (loc, env, Orpat_vars min_var)) in
   unify_vars p1_vs p2_vs
 
 let rec build_as_type env p =
@@ -426,7 +431,7 @@ let rec build_as_type env p =
   | Tpat_tuple pl ->
       let tyl = List.map (build_as_type env) pl in
       newty (Ttuple tyl)
-  | Tpat_construct(_, _, cstr, pl,_) ->
+  | Tpat_construct(_, cstr, pl,_) ->
       let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
       if keep then p.pat_type else
       let tyl = List.map (build_as_type env) pl in
@@ -440,10 +445,10 @@ let rec build_as_type env p =
                       row_bound=(); row_name=None;
                       row_fixed=false; row_closed=false})
   | Tpat_record (lpl,_) ->
-      let lbl = thd4 (List.hd lpl) in
+      let lbl = snd3 (List.hd lpl) in
       if lbl.lbl_private = Private then p.pat_type else
       let ty = newvar () in
-      let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in
+      let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
       let do_label lbl =
         let _, ty_arg, ty_res = instance_label false lbl in
         unify_pat env {p with pat_type = ty} ty_res;
@@ -481,7 +486,7 @@ let build_or_pat env loc lid =
     let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
     match ty.desc with
       Tvariant row when static_row row -> row
-    | _ -> raise(Error(loc, Not_a_variant_type lid))
+    | _ -> raise(Error(loc, env, Not_a_variant_type lid))
   in
   let pats, fields =
     List.fold_left
@@ -510,7 +515,7 @@ let build_or_pat env loc lid =
       pats
   in
   match pats with
-    [] -> raise(Error(loc, Not_a_variant_type lid))
+    [] -> raise(Error(loc, env, Not_a_variant_type lid))
   | pat :: pats ->
       let r =
         List.fold_left
@@ -519,56 +524,288 @@ let build_or_pat env loc lid =
           pat pats in
       (path, rp { r with pat_loc = loc },ty)
 
+(* Type paths *)
+
+let rec expand_path env p =
+  let decl =
+    try Some (Env.find_type p env) with Not_found -> None
+  in
+  match decl with
+    Some {type_manifest = Some ty} ->
+      begin match repr ty with
+        {desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+      end
+  | _ -> p
+
+let compare_type_path env tpath1 tpath2 =
+  Path.same (expand_path env tpath1) (expand_path env tpath2)
+
 (* Records *)
 
+module NameChoice(Name : sig
+  type t
+  val type_kind: string
+  val get_name: t -> string
+  val get_type: t -> type_expr
+  val get_descrs: Env.type_descriptions -> t list
+  val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a
+  val unbound_name_error: Env.t -> Longident.t loc -> 'a
+end) = struct
+  open Name
+
+  let get_type_path env d =
+    match (get_type d).desc with
+    | Tconstr(p, _, _) -> p
+    | _ -> assert false
+
+  let spellcheck ppf env p lid =
+    Typetexp.spellcheck_simple ppf fold
+      (fun d ->
+        if compare_type_path env p (get_type_path env d)
+        then get_name d else "") env lid
+
+  let lookup_from_type env tpath lid =
+    let descrs = get_descrs (Env.find_type_descrs tpath env) in
+    Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
+    match lid.txt with
+      Longident.Lident s -> begin
+        try
+          List.find (fun nd -> get_name nd = s) descrs
+        with Not_found ->
+          raise (Error (lid.loc, env, Wrong_name (type_kind, tpath, lid.txt)))
+      end
+    | _ -> raise Not_found
+
+  let rec unique eq acc = function
+      [] -> List.rev acc
+    | x :: rem ->
+        if List.exists (eq x) acc then unique eq acc rem
+        else unique eq (x :: acc) rem
+
+  let ambiguous_types env lbl others =
+    let tpath = get_type_path env lbl in
+    let others =
+      List.map (fun (lbl, _) -> get_type_path env lbl) others in
+    let tpaths = unique (compare_type_path env) [tpath] others in
+    match tpaths with
+      [_] -> []
+    | _ -> List.map Printtyp.string_of_path tpaths
+
+  let disambiguate_by_type env tpath lbls =
+    let check_type (lbl, _) =
+      let lbl_tpath = get_type_path env lbl in
+      compare_type_path env tpath lbl_tpath
+    in
+    List.find check_type lbls
+
+  let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
+      ?scope lid env opath lbls =
+    let scope = match scope with None -> lbls | Some l -> l in
+    let lbl = match opath with
+      None ->
+        begin match lbls with
+          [] -> unbound_name_error env lid
+        | (lbl, use) :: rest ->
+            use ();
+            let paths = ambiguous_types env lbl rest in
+            if paths <> [] then
+              warn lid.loc
+                (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                          paths, false));
+            lbl
+        end
+    | Some(tpath0, tpath, pr) ->
+        let warn_pr () =
+          let kind = if type_kind = "record" then "field" else "constructor" in
+          warn lid.loc
+            (Warnings.Not_principal
+               ("this type-based " ^ kind ^ " disambiguation"))
+        in
+        try
+          let lbl, use = disambiguate_by_type env tpath scope in
+          use ();
+          if not pr then begin
+            (* Check if non-principal type is affecting result *)
+            match lbls with
+              [] -> warn_pr ()
+            | (lbl', use') :: rest ->
+                let lbl_tpath = get_type_path env lbl' in
+                if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
+                else
+                  let paths = ambiguous_types env lbl rest in
+                  if paths <> [] then
+                    warn lid.loc
+                      (Warnings.Ambiguous_name ([Longident.last lid.txt],
+                                                paths, false))
+          end;
+          lbl
+        with Not_found -> try
+          let lbl = lookup_from_type env tpath lid in
+          check_lk tpath lbl;
+          let s = Printtyp.string_of_path tpath in
+          warn lid.loc
+            (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
+          if not pr then warn_pr ();
+          lbl
+        with Not_found ->
+          if lbls = [] then unbound_name_error env lid else
+          let tp = (tpath0, expand_path env tpath) in
+          let tpl =
+            List.map
+              (fun (lbl, _) ->
+                let tp0 = get_type_path env lbl in
+                let tp = expand_path env tp0 in
+                  (tp0, tp))
+              lbls
+          in
+          raise (Error (lid.loc, env,
+                        Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
+    in
+    begin match scope with
+      (lab1,_)::_ when lab1 == lbl -> ()
+    | _ ->
+        Location.prerr_warning lid.loc
+          (Warnings.Disambiguated_name(get_name lbl))
+    end;
+    lbl
+end
+
+module Label = NameChoice (struct
+  type t = label_description
+  let type_kind = "record"
+  let get_name lbl = lbl.lbl_name
+  let get_type lbl = lbl.lbl_res
+  let get_descrs = snd
+  let fold = Env.fold_labels
+  let unbound_name_error = Typetexp.unbound_label_error
+end)
+
+let disambiguate_label_by_ids keep env closed ids labels =
+  let check_ids (lbl, _) =
+    let lbls = Hashtbl.create 8 in
+    Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+    List.for_all (Hashtbl.mem lbls) ids
+  and check_closed (lbl, _) =
+    (not closed || List.length ids = Array.length lbl.lbl_all)
+  in
+  let labels' = List.filter check_ids labels in
+  if keep && labels' = [] then (false, labels) else
+  let labels'' = List.filter check_closed labels' in
+  if keep && labels'' = [] then (false, labels') else (true, labels'')
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env opath lid_a_list =
+  let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+  let w_pr = ref false and w_amb = ref []
+  and w_scope = ref [] and w_scope_ty = ref "" in
+  let warn loc msg =
+    let open Warnings in
+    match msg with
+    | Not_principal _ -> w_pr := true
+    | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
+    | Name_out_of_scope(ty, [s], _) ->
+        w_scope := s :: !w_scope; w_scope_ty := ty
+    | _ -> Location.prerr_warning loc msg
+  in
+  let process_label lid =
+    (* Strategy for each field:
+       * collect all the labels in scope for that name
+       * if the type is known and principal, just eventually warn
+         if the real label was not in scope
+       * fail if there is no known type and no label found
+       * otherwise use other fields to reduce the list of candidates
+       * if there is no known type reduce it incrementally, so that
+         there is still at least one candidate (for error message)
+       * if the reduced list is valid, call Label.disambiguate
+     *)
+    let scope = Typetexp.find_all_labels env lid.loc lid.txt in
+    if opath = None && scope = [] then
+      Typetexp.unbound_label_error env lid;
+    let (ok, labels) =
+      match opath with
+        Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
+      | _  -> disambiguate_label_by_ids (opath=None) env closed ids scope
+    in
+    if ok then Label.disambiguate lid env opath labels ~warn ~scope
+          else fst (List.hd labels) (* will fail later *)
+  in
+  let lbl_a_list =
+    List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+  if !w_pr then
+    Location.prerr_warning loc
+      (Warnings.Not_principal "this type-based record disambiguation")
+  else begin
+    match List.rev !w_amb with
+      (_,types)::others as amb ->
+        let paths =
+          List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
+        let path = List.hd paths in
+        if List.for_all (compare_type_path env path) (List.tl paths) then
+          Location.prerr_warning loc
+            (Warnings.Ambiguous_name (List.map fst amb, types, true))
+        else
+          List.iter
+            (fun (s,l) -> Location.prerr_warning loc
+                (Warnings.Ambiguous_name ([s],l,false)))
+            amb
+    | _ -> ()
+  end;
+  if !w_scope <> [] then
+    Location.prerr_warning loc
+      (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
+  lbl_a_list
+
 let rec find_record_qual = function
   | [] -> None
   | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
   | _ :: rest -> find_record_qual rest
 
-let type_label_a_list ?labels env type_lbl_a lid_a_list =
-  let record_qual = find_record_qual lid_a_list in
+let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list =
   let lbl_a_list =
-    List.map
-      (fun (lid, a) ->
-        let path, label =
-          match lid.txt, labels, record_qual with
-              Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
-                (Hashtbl.find labels s : Path.t * Types.label_description)
-            | Longident.Lident s, _, Some modname ->
-              Typetexp.find_label env lid.loc (Longident.Ldot (modname, s))
-            | _ ->
-              Typetexp.find_label env lid.loc lid.txt
-        in (path, lid, label, a)
-      )  lid_a_list in
+    match lid_a_list, labels with
+      ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+        (* Special case for rebuilt syntax trees *)
+        List.map
+          (function lid, a -> match lid.txt with
+            Longident.Lident s -> lid, Hashtbl.find labels s, a
+          | _ -> assert false)
+          lid_a_list
+    | _ ->
+        let lid_a_list =
+          match find_record_qual lid_a_list with
+            None -> lid_a_list
+          | Some modname ->
+              List.map
+                (fun (lid, a as lid_a) ->
+                  match lid.txt with Longident.Lident s ->
+                    {lid with txt=Longident.Ldot (modname, s)}, a
+                  | _ -> lid_a)
+                lid_a_list
+        in
+        disambiguate_lid_a_list loc closed env opath lid_a_list
+  in
   (* Invariant: records are sorted in the typed tree *)
   let lbl_a_list =
     List.sort
-      (fun ( _, _, lbl1,_) ( _,_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
       lbl_a_list
   in
   List.map type_lbl_a lbl_a_list
 ;;
 
-let lid_of_label label =
-  match repr label.lbl_res with
-  | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} ->
-      Longident.Ldot(lid_of_path mpath, label.lbl_name)
-  | _ -> Longident.Lident label.lbl_name
-
 (* Checks over the labels mentioned in a record pattern:
    no duplicate definitions (error); properly closed (warning) *)
 
 let check_recordpat_labels loc lbl_pat_list closed =
   match lbl_pat_list with
   | [] -> ()                            (* should not happen *)
-  | (_, _, label1, _) :: _ ->
+  | (_, label1, _) :: _ ->
       let all = label1.lbl_all in
       let defined = Array.make (Array.length all) false in
-      let check_defined (_, _, label, _) =
+      let check_defined (_, label, _) =
         if defined.(label.lbl_pos)
-        then raise(Error(loc, Label_multiply_defined
-                                       (Longident.Lident label.lbl_name)))
+        then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
         else defined.(label.lbl_pos) <- true in
       List.iter check_defined lbl_pat_list;
       if closed = Closed
@@ -584,6 +821,25 @@ let check_recordpat_labels loc lbl_pat_list closed =
         end
       end
 
+(* Constructors *)
+
+let lookup_constructor_from_type env tpath lid =
+  let (constructors, _) = Env.find_type_descrs tpath env in
+    match lid with
+      Longident.Lident s ->
+        List.find (fun cstr -> cstr.cstr_name = s) constructors
+    | _ -> raise Not_found
+
+module Constructor = NameChoice (struct
+  type t = constructor_description
+  let type_kind = "variant"
+  let get_name cstr = cstr.cstr_name
+  let get_type cstr = cstr.cstr_res
+  let get_descrs = fst
+  let fold = Env.fold_constructors
+  let unbound_name_error = Typetexp.unbound_constructor_error
+end)
+
 (* unification of a type with a tconstr with
    freshly created arguments *)
 let unify_head_only loc env ty constr =
@@ -684,15 +940,28 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         pat_type = expected_ty;
         pat_env = !env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
-      let (constr_path, constr) =
+      let opath =
+        try
+          let (p0, p, _) = extract_concrete_variant !env expected_ty in
+            Some (p0, p, true)
+        with Not_found -> None
+      in
+      let constrs =
         match lid.txt, constrs with
           Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
-            Hashtbl.find constrs s
-        | _ ->  Typetexp.find_constructor !env loc lid.txt
+            [Hashtbl.find constrs s, (fun () -> ())]
+        | _ ->  Typetexp.find_all_constructors !env lid.loc lid.txt
+      in
+      let check_lk tpath constr =
+        if constr.cstr_generalized then
+          raise (Error (lid.loc, !env,
+                        Unqualified_gadt_pattern (tpath, constr.cstr_name)))
       in
+      let constr =
+        Constructor.disambiguate lid !env opath constrs ~check_lk in
       Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
       if no_existentials && constr.cstr_existentials <> [] then
-        raise (Error (loc, Unexpected_existential));
+        raise (Error (loc, !env, Unexpected_existential));
       (* if constructor is gadt, we must verify that the expected type has the
          correct head *)
       if constr.cstr_generalized then
@@ -709,7 +978,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
             replicate_list sp constr.cstr_arity
         | Some sp -> [sp] in
       if List.length sargs <> constr.cstr_arity then
-        raise(Error(loc, Constructor_arity_mismatch(lid.txt,
+        raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
                                      constr.cstr_arity, List.length sargs)));
       let (ty_args, ty_res) =
         instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
@@ -720,7 +989,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         unify_pat_types loc !env ty_res expected_ty;
       let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
       rp {
-        pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity);
+        pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
         pat_loc = loc; pat_extra=[];
         pat_type = expected_ty;
         pat_env = !env }
@@ -741,14 +1010,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         pat_type =  expected_ty;
         pat_env = !env }
   | Ppat_record(lid_sp_list, closed) ->
-      let type_label_pat (label_path, label_lid, label, sarg) =
+      let opath, record_ty =
+        try
+          let (p0, p,_) = extract_concrete_record !env expected_ty in
+          Some (p0, p, true), expected_ty
+        with Not_found -> None, newvar ()
+      in
+      let type_label_pat (label_lid, label, sarg) =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
         begin try
-          unify_pat_types loc !env ty_res expected_ty
+          unify_pat_types loc !env ty_res record_ty
         with Unify trace ->
-          raise(Error(loc, Label_mismatch(lid_of_label label, trace)))
+          raise(Error(label_lid.loc, !env,
+                      Label_mismatch(label_lid.txt, trace)))
         end;
         let arg = type_pat sarg ty_arg in
         if vars <> [] then begin
@@ -759,13 +1035,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
             let tv = expand_head !env tv in
             not (is_Tvar tv) || tv.level <> generic_level in
           if List.exists instantiated vars then
-            raise (Error(loc, Polymorphic_label (lid_of_label label)))
+            raise (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt))
         end;
-        (label_path, label_lid, label, arg)
+        (label_lid, label, arg)
       in
       let lbl_pat_list =
-        type_label_a_list ?labels !env type_label_pat lid_sp_list in
+        type_label_a_list ?labels loc false !env type_label_pat opath
+          lid_sp_list in
       check_recordpat_labels loc lbl_pat_list closed;
+      unify_pat_types loc !env record_ty expected_ty;
       rp {
         pat_desc = Tpat_record (lbl_pat_list, closed);
         pat_loc = loc; pat_extra=[];
@@ -886,12 +1164,12 @@ let rec iter3 f lst1 lst2 lst3 =
 let add_pattern_variables ?check ?check_as env =
   let pv = get_ref pattern_variables in
   (List.fold_right
-    (fun (id, ty, name, loc, as_var) env ->
+     (fun (id, ty, name, loc, as_var) env ->
        let check = if as_var then check_as else check in
-       let e1 = Env.add_value ?check id
-           {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in
-       Env.add_annot id (Annot.Iref_internal loc) e1)
-    pv env,
+       Env.add_value ?check id
+         {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env
+     )
+     pv env,
    get_ref module_variables)
 
 let type_pattern ~lev env spat scope expected_ty =
@@ -988,6 +1266,16 @@ let force_delayed_checks () =
 let fst3 (x, _, _) = x
 let snd3 (_, x, _) = x
 
+let rec final_subexpression sexp =
+  match sexp.pexp_desc with
+    Pexp_let (_, _, e)
+  | Pexp_sequence (_, e)
+  | Pexp_try (e, _)
+  | Pexp_ifthenelse (_, e, _)
+  | Pexp_match (_, (_, e) :: _)
+    -> final_subexpression e
+  | _ -> sexp
+
 (* Generalization criterion for expressions *)
 
 let rec is_nonexpansive exp =
@@ -1000,17 +1288,20 @@ let rec is_nonexpansive exp =
   | Texp_function _ -> true
   | Texp_apply(e, (_,None,_)::el) ->
       is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el)
+  | Texp_match(e, pat_exp_list, _) ->
+      is_nonexpansive e &&
+      List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list
   | Texp_tuple el ->
       List.for_all is_nonexpansive el
-  | Texp_construct(_, _, _, el,_) ->
+  | Texp_construct( _, _, el,_) ->
       List.for_all is_nonexpansive el
   | Texp_variant(_, arg) -> is_nonexpansive_opt arg
   | Texp_record(lbl_exp_list, opt_init_exp) ->
       List.for_all
-        (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
+        (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
         lbl_exp_list
       && is_nonexpansive_opt opt_init_exp
-  | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp
+  | Texp_field(exp, lbl, _) -> is_nonexpansive exp
   | Texp_array [] -> true
   | Texp_ifthenelse(cond, ifso, ifnot) ->
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
@@ -1085,9 +1376,9 @@ let type_format loc fmt =
   let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
 
   let bad_conversion fmt i c =
-    raise (Error (loc, Bad_conversion (fmt, i, c))) in
+    raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
   let incomplete_format fmt =
-    raise (Error (loc, Incomplete_format fmt)) in
+    raise (Error (loc, Env.empty, Incomplete_format fmt)) in
 
   let rec type_in_format fmt =
 
@@ -1173,7 +1464,7 @@ let type_format loc fmt =
           match fmt.[j] with
           | ']' -> scan_closing (j + 1)
           | c -> scan_closing j in
-        let rec scan_first_neg j =
+        let scan_first_neg j =
           if j >= len then incomplete_format fmt else
           match fmt.[j] with
           | '^' -> scan_first_pos (j + 1)
@@ -1315,7 +1606,7 @@ let rec type_approx env sexp =
       and ty1 = approx_ty_opt sty1
       and ty2 = approx_ty_opt sty2 in
       begin try unify env ty ty1 with Unify trace ->
-        raise(Error(sexp.pexp_loc, Expr_type_clash trace))
+        raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
       end;
       if sty2 = None then ty1 else ty2
   | _ -> newvar ()
@@ -1353,7 +1644,7 @@ let check_univars env expans kind exp ty_expected vars =
   if List.length vars = List.length vars' then () else
   let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
   and ty_expected = repr ty_expected in
-  raise (Error (exp.exp_loc,
+  raise (Error (exp.exp_loc, env,
                 Less_general(kind, [ty, ty; ty_expected, ty_expected])))
 
 (* Check that a type is not a function *)
@@ -1405,6 +1696,28 @@ let create_package_type loc env (p, l) =
     sexp unpacks
 
 (* Helpers for type_cases *)
+
+let contains_variant_either ty =
+  let rec loop ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      match ty.desc with
+        Tvariant row ->
+          let row = row_repr row in
+          if not row.row_fixed then
+            List.iter
+              (fun (_,f) ->
+                match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+              row.row_fields;
+          iter_row loop row
+      | _ ->
+          iter_type_expr loop ty
+    end
+  in
+  try loop ty; unmark_type ty; false
+  with Exit -> unmark_type ty; true
+
 let iter_ppat f p =
   match p.ppat_desc with
   | Ppat_any | Ppat_var _ | Ppat_constant _
@@ -1429,14 +1742,34 @@ let contains_gadt env p =
     match p.ppat_desc with
       Ppat_construct (lid, _, _) ->
         begin try
-                let (_path, cstr) = Env.lookup_constructor lid.txt env in
-          if cstr.cstr_generalized then raise Exit
+          let cstrs = Env.lookup_all_constructors lid.txt env in
+          List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
+            cstrs
         with Not_found -> ()
         end; iter_ppat loop p
     | _ -> iter_ppat loop p
   in
   try loop p; false with Exit -> true
 
+let check_absent_variant env =
+  iter_pattern
+    (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
+      let row = row_repr !row in
+      if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+          row.row_fields
+      || not row.row_fixed && not (static_row row)  (* same as Ctype.poly *)
+      then () else
+      let ty_arg =
+        match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+      let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+                  row_more = newvar (); row_bound = ();
+                  row_closed = false; row_fixed = false; row_name = None} in
+      (* Should fail *)
+      unify_pat env {pat with pat_type = newty (Tvariant row')}
+                    (correct_levels pat.pat_type)
+      | _ -> ())
+
+
 let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
 
 (* Duplicate types of values in the environment *)
@@ -1478,25 +1811,31 @@ let rec type_exp env sexp =
  *)
 
 and type_expect ?in_function env sexp ty_expected =
+  let previous_saved_types = Cmt_format.get_saved_types () in
+  let exp = type_expect_ ?in_function env sexp ty_expected in
+  Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types);
+  exp
+
+and type_expect_ ?in_function env sexp ty_expected =
   let loc = sexp.pexp_loc in
   (* Record the expression type before unifying it with the expected type *)
   let rue exp =
-    Cmt_format.add_saved_type (Cmt_format.Partial_expression exp);
-    Stypes.record (Stypes.Ti_expr exp);
-    unify_exp env exp (instance env ty_expected);
+    unify_exp env (re exp) (instance env ty_expected);
     exp
   in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
+        let (path, desc) = Typetexp.find_value env loc lid.txt in
         if !Clflags.annotations then begin
-          try let (path, annot) = Env.lookup_annot lid.txt env in
-              Stypes.record
-                (Stypes.An_ident (
-                 loc, Path.name ~paren:Oprint.parenthesized_ident path, annot))
-          with _ -> ()
+          let dloc = desc.Types.val_loc in
+          let annot =
+            if dloc.Location.loc_ghost then Annot.Iref_external
+            else Annot.Iref_internal dloc
+          in
+          let name = Path.name ~paren:Oprint.parenthesized_ident path in
+          Stypes.record (Stypes.An_ident (loc, name, annot))
         end;
-        let (path, desc) = Typetexp.find_value env loc lid.txt in
         rue {
           exp_desc =
             begin match desc.val_kind with
@@ -1514,7 +1853,7 @@ and type_expect ?in_function env sexp ty_expected =
                 in
                 Texp_ident(path, lid, desc)
             | Val_unbound ->
-                raise(Error(loc, Masked_instance_variable lid.txt))
+                raise(Error(loc, env, Masked_instance_variable lid.txt))
             | _ ->
                 Texp_ident(path, lid, desc)
           end;
@@ -1614,9 +1953,9 @@ and type_expect ?in_function env sexp ty_expected =
         with Unify _ ->
           match expand_head env ty_expected with
             {desc = Tarrow _} as ty ->
-              raise(Error(loc, Abstract_wrong_label(l, ty)))
+              raise(Error(loc, env, Abstract_wrong_label(l, ty)))
           | _ ->
-              raise(Error(loc_fun,
+              raise(Error(loc_fun, env,
                           Too_many_arguments (in_function <> None, ty_fun)))
       in
       let ty_arg =
@@ -1749,48 +2088,81 @@ and type_expect ?in_function env sexp ty_expected =
           exp_env = env }
       end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
+      let opt_exp =
+        match opt_sexp with
+          None -> None
+        | Some sexp ->
+            if !Clflags.principal then begin_def ();
+            let exp = type_exp env sexp in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure exp.exp_type
+            end;
+            Some exp
+      in
+      let ty_record, opath =
+        let get_path ty =
+          try
+            let (p0, p,_) = extract_concrete_record env ty in
+            (* XXX level may be wrong *)
+            Some (p0, p, ty.level = generic_level || not !Clflags.principal)
+          with Not_found -> None
+        in
+        match get_path ty_expected with
+          None ->
+            let op =
+              match opt_exp with
+                None -> None
+              | Some exp -> get_path exp.exp_type
+            in
+            newvar (), op
+        | op -> ty_expected, op
+      in
+      let closed = (opt_sexp = None) in
       let lbl_exp_list =
-        type_label_a_list env (type_label_exp true env loc ty_expected)
-          lid_sexp_list in
-      let rec check_duplicates seen_pos lid_sexp lbl_exp =
-        match (lid_sexp, lbl_exp) with
-          ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) ->
-            if List.mem lbl.lbl_pos seen_pos
-            then raise(Error(loc, Label_multiply_defined lid.txt))
-            else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
-        | (_, _) -> () in
-      check_duplicates [] lid_sexp_list lbl_exp_list;
+        type_label_a_list loc closed env
+          (type_label_exp true env loc ty_record)
+          opath lid_sexp_list in
+      unify_exp_types loc env ty_record (instance env ty_expected);
+
+      (* type_label_a_list returns a list of labels sorted by lbl_pos *)
+      (* note: check_duplicates would better be implemented in
+         type_label_a_list directly *)
+      let rec check_duplicates = function
+        | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
+          raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
+        | _ :: rem ->
+            check_duplicates rem
+        | [] -> ()
+      in
+      check_duplicates lbl_exp_list;
       let opt_exp =
-        match opt_sexp, lbl_exp_list with
+        match opt_exp, lbl_exp_list with
           None, _ -> None
-        | Some sexp, (_, _, lbl, _) :: _ ->
-            if !Clflags.principal then begin_def ();
-            let ty_exp = newvar () in
+        | Some exp, (lid, lbl, lbl_exp) :: _ ->
+            let ty_exp = instance env exp.exp_type in
             let unify_kept lbl =
+              (* do not connect overridden labels *)
               if List.for_all
-                  (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
+                  (fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
                   lbl_exp_list
               then begin
                 let _, ty_arg1, ty_res1 = instance_label false lbl
                 and _, ty_arg2, ty_res2 = instance_label false lbl in
-                unify env ty_exp ty_res1;
+                unify env ty_arg1 ty_arg2;
                 unify env (instance env ty_expected) ty_res2;
-                unify env ty_arg1 ty_arg2
+                unify_exp_types exp.exp_loc env ty_exp ty_res1;
               end in
             Array.iter unify_kept lbl.lbl_all;
-            if !Clflags.principal then begin
-              end_def ();
-              generalize_structure ty_exp
-            end;
-            Some(type_expect env sexp ty_exp)
+            Some {exp with exp_type = ty_exp}
         | _ -> assert false
       in
       let num_fields =
         match lbl_exp_list with [] -> assert false
-        | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in
+        | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
       if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
         let present_indices =
-          List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
+          List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
         let label_names = extract_label_names sexp env ty_expected in
         let rec missing_labels n = function
             [] -> []
@@ -1799,7 +2171,7 @@ and type_expect ?in_function env sexp ty_expected =
               else lbl :: missing_labels (n + 1) rem
         in
         let missing = missing_labels 0 label_names in
-        raise(Error(loc, Label_missing missing))
+        raise(Error(loc, env, Label_missing missing))
       end
       else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
         Location.prerr_warning loc Warnings.Useless_record_with;
@@ -1808,26 +2180,25 @@ and type_expect ?in_function env sexp ty_expected =
         exp_loc = loc; exp_extra = [];
         exp_type = instance env ty_expected;
         exp_env = env }
-  | Pexp_field(sarg, lid) ->
-      let arg = type_exp env sarg in
-      let (label_path,label) = Typetexp.find_label env loc lid.txt in
+  | Pexp_field(srecord, lid) ->
+      let (record, label, _) = type_label_access env loc srecord lid in
       let (_, ty_arg, ty_res) = instance_label false label in
-      unify_exp env arg ty_res;
+      unify_exp env record ty_res;
       rue {
-        exp_desc = Texp_field(arg, label_path, lid, label);
+        exp_desc = Texp_field(record, lid, label);
         exp_loc = loc; exp_extra = [];
         exp_type = ty_arg;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
-      let record = type_exp env srecord in
-      let (label_path, label) = Typetexp.find_label env loc lid.txt in
-      let (label_path, label_loc, label, newval) =
-        type_label_exp false env loc record.exp_type
-          (label_path, lid, label, snewval) in
+      let (record, label, opath) = type_label_access env loc srecord lid in
+      let ty_record = if opath = None then newvar () else record.exp_type in
+      let (label_loc, label, newval) =
+        type_label_exp false env loc ty_record (lid, label, snewval) in
+      unify_exp env record ty_record;
       if label.lbl_mut = Immutable then
-        raise(Error(loc, Label_not_mutable lid.txt));
+        raise(Error(loc, env, Label_not_mutable lid.txt));
       rue {
-        exp_desc = Texp_setfield(record, label_path, label_loc, label, newval);
+        exp_desc = Texp_setfield(record, label_loc, label, newval);
         exp_loc = loc; exp_extra = [];
         exp_type = instance_def Predef.type_unit;
         exp_env = env }
@@ -1893,7 +2264,6 @@ and type_expect ?in_function env sexp ty_expected =
         exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_constraint(sarg, sty, sty') ->
-
       let separate = true (* always separate, 1% slowdown for lablgtk *)
         (* !Clflags.principal || Env.has_local_constraints env *) in
       let (arg, ty',cty,cty') =
@@ -1952,13 +2322,13 @@ and type_expect ?in_function env sexp ty_expected =
                       (Warnings.Not_principal "this ground coercion");
                 with Subtype (tr1, tr2) ->
                   (* prerr_endline "coercion failed"; *)
-                  raise(Error(loc, Not_subtype(tr1, tr2)))
+                  raise(Error(loc, env, Not_subtype(tr1, tr2)))
                 end;
             | _ ->
                 let ty, b = enlarge_type env ty' in
                 force ();
                 begin try Ctype.unify env arg.exp_type ty with Unify trace ->
-                  raise(Error(sarg.pexp_loc,
+                  raise(Error(sarg.pexp_loc, env,
                         Coercion_failure(ty', full_expand env ty', trace, b)))
                 end
             end;
@@ -1976,7 +2346,7 @@ and type_expect ?in_function env sexp ty_expected =
               let force'' = subtype env ty ty' in
               force (); force' (); force'' ()
             with Subtype (tr1, tr2) ->
-              raise(Error(loc, Not_subtype(tr1, tr2)))
+              raise(Error(loc, env, Not_subtype(tr1, tr2)))
             end;
             if separate then begin
               end_def ();
@@ -2019,7 +2389,7 @@ and type_expect ?in_function env sexp ty_expected =
           | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
               let method_id =
                 begin try List.assoc met methods with Not_found ->
-                  raise(Error(e.pexp_loc, Undefined_inherited_method met))
+                  raise(Error(e.pexp_loc, env, Undefined_inherited_method met))
                 end
               in
               begin match
@@ -2090,13 +2460,13 @@ and type_expect ?in_function env sexp ty_expected =
           exp_type = typ;
           exp_env = env }
       with Unify _ ->
-        raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
+        raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met)))
       end
   | Pexp_new cl ->
       let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
         begin match cl_decl.cty_new with
           None ->
-            raise(Error(loc, Virtual_class cl.txt))
+            raise(Error(loc, env, Virtual_class cl.txt))
         | Some ty ->
             rue {
               exp_desc = Texp_new (cl_path, cl, cl_decl);
@@ -2120,19 +2490,19 @@ and type_expect ?in_function env sexp ty_expected =
               exp_type = instance_def Predef.type_unit;
               exp_env = env }
         | Val_ivar _ ->
-            raise(Error(loc,Instance_variable_not_mutable(true,lab.txt)))
+            raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
         | _ ->
-            raise(Error(loc,Instance_variable_not_mutable(false,lab.txt)))
+            raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt)))
       with
         Not_found ->
-          raise(Error(loc, Unbound_instance_variable lab.txt))
+          raise(Error(loc, env, Unbound_instance_variable lab.txt))
       end
   | Pexp_override lst ->
       let _ =
        List.fold_right
         (fun (lab, _) l ->
            if List.exists (fun l -> l.txt = lab.txt) l then
-             raise(Error(loc,
+             raise(Error(loc, env,
                          Value_multiply_overridden lab.txt));
            lab::l)
         lst
@@ -2142,7 +2512,7 @@ and type_expect ?in_function env sexp ty_expected =
           Env.lookup_value (Longident.Lident "selfpat-*") env,
           Env.lookup_value (Longident.Lident "self-*") env
         with Not_found ->
-          raise(Error(loc, Outside_class))
+          raise(Error(loc, env, Outside_class))
       with
         (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
         (path_self, _) ->
@@ -2152,7 +2522,7 @@ and type_expect ?in_function env sexp ty_expected =
               (Path.Pident id, lab, type_expect env snewval (instance env ty))
             with
               Not_found ->
-                raise(Error(loc, Unbound_instance_variable lab.txt))
+                raise(Error(loc, env, Unbound_instance_variable lab.txt))
             end
           in
           let modifs = List.map type_override lst in
@@ -2185,7 +2555,7 @@ and type_expect ?in_function env sexp ty_expected =
       begin try
         Ctype.unify_var new_env ty body.exp_type
       with Unify _ ->
-        raise(Error(loc, Scoping_let_module(name.txt, body.exp_type)))
+        raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
       end;
       re {
         exp_desc = Texp_letmodule(id, name, modl, body);
@@ -2322,9 +2692,9 @@ and type_expect ?in_function env sexp ty_expected =
                 (Warnings.Not_principal "this module packing");
             (p, nl, tl)
         | {desc = Tvar _} ->
-            raise (Error (loc, Cannot_infer_signature))
+            raise (Error (loc, env, Cannot_infer_signature))
         | _ ->
-            raise (Error (loc, Not_a_packed_module ty_expected))
+            raise (Error (loc, env, Not_a_packed_module ty_expected))
       in
       let (modl, tl') = !type_package env m p nl tl in
       rue {
@@ -2332,15 +2702,34 @@ and type_expect ?in_function env sexp ty_expected =
         exp_loc = loc; exp_extra = [];
         exp_type = newty (Tpackage (p, nl, tl'));
         exp_env = env }
-  | Pexp_open (lid, e) ->
-      let (path, newenv) = !type_open env sexp.pexp_loc lid in
+  | Pexp_open (ovf, lid, e) ->
+      let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
       let exp = type_expect newenv e ty_expected in
       { exp with
-        exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
+        exp_extra = (Texp_open (ovf, path, lid, newenv), loc) ::
+                      exp.exp_extra;
       }
 
+and type_label_access env loc srecord lid =
+  if !Clflags.principal then begin_def ();
+  let record = type_exp env srecord in
+  if !Clflags.principal then begin
+    end_def ();
+    generalize_structure record.exp_type
+  end;
+  let ty_exp = record.exp_type in
+  let opath =
+    try
+      let (p0, p,_) = extract_concrete_record env ty_exp in
+      Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let labels = Typetexp.find_all_labels env lid.loc lid.txt in
+  let label = Label.disambiguate lid env opath labels in
+  (record, label, opath)
+
 and type_label_exp create env loc ty_expected
-          (label_path, lid, label, sarg) =
+          (lid, label, sarg) =
   (* Here also ty_expected may be at generic_level *)
   begin_def ();
   let separate = !Clflags.principal || Env.has_local_constraints env in
@@ -2355,7 +2744,7 @@ and type_label_exp create env loc ty_expected
   begin try
     unify env (instance_def ty_res) (instance env ty_expected)
   with Unify trace ->
-    raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace)))
+    raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
   end;
   (* Instantiate so that we can generalize internal nodes *)
   let ty_arg = instance_def ty_arg in
@@ -2366,9 +2755,9 @@ and type_label_exp create env loc ty_expected
   end;
   if label.lbl_private = Private then
     if create then
-      raise (Error(loc, Private_type ty_expected))
+      raise (Error(loc, env, Private_type ty_expected))
     else
-      raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected)));
+      raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
   let arg =
     let snap = if vars = [] then None else Some (Btype.snapshot ()) in
     let arg = type_argument env sarg ty_arg (instance env ty_arg) in
@@ -2386,10 +2775,10 @@ and type_label_exp create env loc ty_expected
       unify_exp env arg ty_arg;
       check_univars env false "field value" arg label.lbl_arg vars;
       arg
-    with Error (_, Less_general _) as e -> raise e
+    with Error (_, _, Less_general _) as e -> raise e
     | _ -> raise exn    (* In case of failure return the first error *)
   in
-  (label_path, lid, label, {arg with exp_type = instance env arg.exp_type})
+  (lid, label, {arg with exp_type = instance env arg.exp_type})
 
 and type_argument env sarg ty_expected' ty_expected =
   (* ty_expected' may be generic *)
@@ -2400,7 +2789,7 @@ and type_argument env sarg ty_expected' ty_expected =
   let rec is_inferred sexp =
     match sexp.pexp_desc with
       Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true
-    | Pexp_open (_, e) -> is_inferred e
+    | Pexp_open (_, _, e) -> is_inferred e
     | _ -> false
   in
   match expand_head env ty_expected' with
@@ -2416,10 +2805,8 @@ and type_argument env sarg ty_expected' ty_expected =
       let rec make_args args ty_fun =
         match (expand_head env ty_fun).desc with
         | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
-            make_args
-              ((Some(option_none (instance env ty_arg) sarg.pexp_loc), Optional)
-               :: args)
-              ty_fun
+            let ty = option_none (instance env ty_arg) sarg.pexp_loc in
+            make_args ((l, Some ty, Optional) :: args) ty_fun
         | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
             args, ty_fun, no_labels ty_res'
         | Tvar _ ->  args, ty_fun, false
@@ -2453,15 +2840,13 @@ and type_argument env sarg ty_expected' ty_expected =
         { texp with exp_type = ty_fun; exp_desc =
           Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
                     Texp_apply (texp,
-                      (List.map (fun (label, exp) ->
-                          ("", label, exp)) args)@
-                                               ["", Some eta_var, Required])}],
+                                List.rev args @ ["", Some eta_var, Required])}],
                         Total) } in
       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 "let" texp.exp_type in
+      let let_pat, let_var = var_pair "arg" texp.exp_type in
       re { texp with exp_type = ty_fun; exp_desc =
            Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
       end
@@ -2519,11 +2904,12 @@ and type_application env funct sargs =
               match ty_res.desc with
                 Tarrow _ ->
                   if (!Clflags.classic || not (has_label l1 ty_fun)) then
-                    raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
+                    raise (Error(sarg1.pexp_loc, env,
+                                 Apply_wrong_label(l1, ty_res)))
                   else
-                    raise(Error(funct.exp_loc, Incoherent_label_order))
+                    raise (Error(funct.exp_loc, env, Incoherent_label_order))
               | _ ->
-                  raise(Error(funct.exp_loc, Apply_non_function
+                  raise(Error(funct.exp_loc, env, Apply_non_function
                                 (expand_head env funct.exp_type)))
         in
         let optional = if is_optional l1 then Optional else Required in
@@ -2568,10 +2954,12 @@ and type_application env funct sargs =
             (* In classic mode, omitted = [] *)
             match sargs, more_sargs with
               (l', sarg0) :: _, _ ->
-                raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
+                raise(Error(sarg0.pexp_loc, env,
+                            Apply_wrong_label(l', ty_old)))
             | _, (l', sarg0) :: more_sargs ->
                 if l <> l' && l' <> "" then
-                  raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
+                  raise(Error(sarg0.pexp_loc, env,
+                              Apply_wrong_label(l', ty_fun')))
                 else
                   ([], more_sargs,
                    Some (fun () -> type_argument env sarg0 ty ty0))
@@ -2593,6 +2981,9 @@ and type_application env funct sargs =
                     (Warnings.Not_principal "commuting this argument");
                 (l', sarg0, sargs @ sargs1, sargs2)
             in
+            if optional = Required && is_optional l' then
+              Location.prerr_warning sarg0.pexp_loc
+                (Warnings.Nonoptional_label l);
             sargs, more_sargs,
             if optional = Required || is_optional l' then
               Some (fun () -> type_argument env sarg0 ty ty0)
@@ -2626,7 +3017,8 @@ and type_application env funct sargs =
     | _ ->
         match sargs with
           (l, sarg0) :: _ when ignore_labels ->
-            raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
+            raise(Error(sarg0.pexp_loc, env,
+                        Apply_wrong_label(l, ty_old)))
         | _ ->
             type_unknown_args args omitted ty_fun0
               (sargs @ more_sargs)
@@ -2653,7 +3045,14 @@ and type_application env funct sargs =
         type_args [] [] ty (instance env ty) ty sargs []
 
 and type_construct env loc lid sarg explicit_arity ty_expected =
-  let (path,constr) = Typetexp.find_constructor env loc lid.txt in
+  let opath =
+    try
+      let (p0, p,_) = extract_concrete_variant env ty_expected in
+      Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+    with Not_found -> None
+  in
+  let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+  let constr = Constructor.disambiguate lid env opath constrs in
   Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
   let sargs =
     match sarg with
@@ -2662,14 +3061,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
     | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
     | Some se -> [se] in
   if List.length sargs <> constr.cstr_arity then
-    raise(Error(loc, Constructor_arity_mismatch
+    raise(Error(loc, env, Constructor_arity_mismatch
                   (lid.txt, constr.cstr_arity, List.length sargs)));
   let separate = !Clflags.principal || Env.has_local_constraints env in
   if separate then (begin_def (); begin_def ());
   let (ty_args, ty_res) = instance_constructor constr in
   let texp =
     re {
-      exp_desc = Texp_construct(path, lid, constr, [],explicit_arity);
+      exp_desc = Texp_construct(lid, constr, [],explicit_arity);
       exp_loc = loc; exp_extra = [];
       exp_type = ty_res;
       exp_env = env } in
@@ -2692,14 +3091,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
   let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
       (List.combine ty_args ty_args0) in
   if constr.cstr_private = Private then
-    raise(Error(loc, Private_type ty_res));
+    raise(Error(loc, env, Private_type ty_res));
   { texp with
-    exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) }
+    exp_desc = Texp_construct(lid, constr, args, explicit_arity) }
 
 (* Typing of statements (expressions whose values are discarded) *)
 
 and type_statement env sexp =
-  let loc = sexp.pexp_loc in
+  let loc = (final_subexpression sexp).pexp_loc in
   begin_def();
   let exp = type_exp env sexp in
   end_def();
@@ -2726,16 +3125,20 @@ and type_statement env sexp =
 
 and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
   (* ty_arg is _fully_ generalized *)
-  let dont_propagate, has_gadts =
-    let patterns = List.map fst caselist in
-    List.exists contains_polymorphic_variant patterns,
-    List.exists (contains_gadt env) patterns in
+  let patterns = List.map fst caselist in
+  let erase_either =
+    List.exists contains_polymorphic_variant patterns
+    && contains_variant_either ty_arg
+  and has_gadts = List.exists (contains_gadt env) patterns in
 (*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
-  let ty_arg, ty_res, env =
+  let ty_arg =
+    if (has_gadts || erase_either) && not !Clflags.principal
+    then correct_levels ty_arg else ty_arg
+  and ty_res, env =
     if has_gadts && not !Clflags.principal then
-      correct_levels ty_arg, correct_levels ty_res,
-      duplicate_ident_types loc caselist env
-    else ty_arg, ty_res, env in
+      correct_levels ty_res, duplicate_ident_types loc caselist env
+    else ty_res, env
+  in
   let lev, env =
     if has_gadts then begin
       (* raise level for existentials *)
@@ -2761,10 +3164,10 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
         let scope = Some (Annot.Idef loc) in
         let (pat, ext_env, force, unpacks) =
           let partial =
-            if !Clflags.principal then Some false else None in
-          let ty_arg =
-            if dont_propagate then newvar () else instance ?partial env ty_arg
-          in type_pattern ~lev env spat scope ty_arg
+            if !Clflags.principal || erase_either
+            then Some false else None in
+          let ty_arg = instance ?partial env ty_arg in
+          type_pattern ~lev env spat scope ty_arg
         in
         pattern_force := force @ !pattern_force;
         let pat =
@@ -2823,7 +3226,11 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     else
       Partial
   in
-  add_delayed_check (fun () -> Parmatch.check_unused env cases);
+  add_delayed_check
+    (fun () ->
+      List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
+        pat_env_list;
+      Parmatch.check_unused env cases);
   if has_gadts then begin
     end_def ();
     (* Ensure that existential types do not escape *)
@@ -3041,9 +3448,9 @@ let type_expression env sexp =
 open Format
 open Printtyp
 
-let report_error ppf = function
+let report_error env ppf = function
   | Polymorphic_label lid ->
-      fprintf ppf "@[The record field label %a is polymorphic.@ %s@]"
+      fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
         longident lid "You cannot instantiate it in a pattern."
   | Constructor_arity_mismatch(lid, expected, provided) ->
       fprintf ppf
@@ -3051,14 +3458,14 @@ let report_error ppf = function
         but is applied here to %i argument(s)@]"
        longident lid expected provided
   | Label_mismatch(lid, trace) ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (function ppf ->
-           fprintf ppf "The record field label %a@ belongs to the type"
+           fprintf ppf "The record field %a@ belongs to the type"
                    longident lid)
         (function ppf ->
-           fprintf ppf "but is mixed here with labels of type")
+           fprintf ppf "but is mixed here with fields of type")
   | Pattern_type_clash trace ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (function ppf ->
           fprintf ppf "This pattern matches values of type")
         (function ppf ->
@@ -3069,19 +3476,23 @@ let report_error ppf = function
       fprintf ppf "Variable %s must occur on both sides of this | pattern"
         (Ident.name id)
   | Expr_type_clash trace ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "This expression has type")
         (function ppf ->
            fprintf ppf "but an expression was expected of type")
   | Apply_non_function typ ->
+      reset_and_mark_loops typ;
       begin match (repr typ).desc with
         Tarrow _ ->
-          fprintf ppf "This function is applied to too many arguments;@ ";
-          fprintf ppf "maybe you forgot a `;'"
+          fprintf ppf "@[@[<2>This function has type@ %a@]"
+            type_expr typ;
+          fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]"
+                      "maybe you forgot a `;'."
       | _ ->
-          fprintf ppf
-            "This expression is not a function; it cannot be applied"
+          fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]"
+            type_expr typ
+            "This is not a function; it cannot be applied."
       end
   | Apply_wrong_label (l, ty) ->
       let print_label ppf = function
@@ -3094,16 +3505,33 @@ let report_error ppf = function
         "@[@[<2>The function applied to this argument has type@ %a@]@.\
           This argument cannot be applied %a@]"
         type_expr ty print_label l
-  | Label_multiply_defined lid ->
-      fprintf ppf "The record field label %a is defined several times"
-              longident lid
+  | Label_multiply_defined s ->
+      fprintf ppf "The record field label %s is defined several times" s
   | Label_missing labels ->
       let print_labels ppf =
         List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
-      fprintf ppf "@[Some record field labels are undefined:%a@]"
+      fprintf ppf "@[Some record fields are undefined:%a@]"
         print_labels labels
   | Label_not_mutable lid ->
-      fprintf ppf "The record field label %a is not mutable" longident lid
+      fprintf ppf "The record field %a is not mutable" longident lid
+  | Wrong_name (kind, p, lid) ->
+      fprintf ppf "The %s type %a has no %s %a" kind path p
+        (if kind = "record" then "field" else "constructor")
+        longident lid;
+      if kind = "record" then Label.spellcheck ppf env p lid
+                         else Constructor.spellcheck ppf env p lid
+  | Name_type_mismatch (kind, lid, tp, tpl) ->
+      let name = if kind = "record" then "field" else "constructor" in
+      report_ambiguous_type_error ppf env tp tpl
+        (function ppf ->
+           fprintf ppf "The %s %a@ belongs to the %s type"
+             name longident lid kind)
+        (function ppf ->
+           fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+             name longident lid kind)
+        (function ppf ->
+           fprintf ppf "but a %s was expected belonging to the %s type"
+             name kind)
   | Incomplete_format s ->
       fprintf ppf "Premature end of format string ``%S''" s
   | Bad_conversion (fmt, i, c) ->
@@ -3128,13 +3556,13 @@ let report_error ppf = function
       else
         fprintf ppf "The value %s is not an instance variable" v
   | Not_subtype(tr1, tr2) ->
-      report_subtyping_error ppf tr1 "is not a subtype of" tr2
+      report_subtyping_error ppf env tr1 "is not a subtype of" tr2
   | Outside_class ->
       fprintf ppf "This object duplication occurs outside a method definition"
   | Value_multiply_overridden v ->
       fprintf ppf "The instance variable %s is overridden several times" v
   | Coercion_failure (ty, ty', trace, b) ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (function ppf ->
            let ty, ty' = prepare_expansion (ty, ty') in
            fprintf ppf
@@ -3187,7 +3615,7 @@ let report_error ppf = function
       fprintf ppf "in an order different from other calls.@ ";
       fprintf ppf "This is only allowed when the real type is known."
   | Less_general (kind, trace) ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
   | Modules_not_allowed ->
@@ -3200,7 +3628,7 @@ let report_error ppf = function
         "This expression is packed module, but the expected type is@ %a"
         type_expr ty
   | Recursive_local_constraint trace ->
-      report_unification_error ppf trace
+      report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "Recursive local constraint when unifying")
         (function ppf ->
@@ -3208,6 +3636,13 @@ let report_error ppf = function
   | Unexpected_existential ->
       fprintf ppf
         "Unexpected existential"
+  | Unqualified_gadt_pattern (tpath, name) ->
+      fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
+        name path tpath
+        "must be qualified in this pattern"
+
+let report_error env ppf err =
+  wrap_printing_env env (fun () -> report_error env ppf err)
 
 let () =
   Env.add_delayed_check_forward := add_delayed_check
diff --git a/typing/typecore.mli b/typing/typecore.mli
index d3b6c649..8840a34d 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typecore.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
 (* Type inference for the core language *)
 
 open Asttypes
@@ -74,9 +72,12 @@ type error =
   | Expr_type_clash of (type_expr * type_expr) list
   | Apply_non_function of type_expr
   | Apply_wrong_label of label * type_expr
-  | Label_multiply_defined of Longident.t
+  | Label_multiply_defined of string
   | Label_missing of Ident.t list
   | Label_not_mutable of Longident.t
+  | Wrong_name of string * Path.t * Longident.t
+  | Name_type_mismatch of
+      string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
   | Incomplete_format of string
   | Bad_conversion of string * int * char
   | Undefined_method of type_expr * string
@@ -103,15 +104,18 @@ type error =
   | Not_a_packed_module of type_expr
   | Recursive_local_constraint of (type_expr * type_expr) list
   | Unexpected_existential
+  | Unqualified_gadt_pattern of Path.t * string
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 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: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref
+val type_open:
+    (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:
   (Env.t -> Location.t -> Parsetree.class_structure ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 79225278..74eab341 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedecl.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (**** Typing of type definitions ****)
 
 open Misc
@@ -29,15 +27,15 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Inconsistent_constraint of (type_expr * type_expr) list
-  | Type_clash of (type_expr * type_expr) list
+  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+  | Type_clash of Env.t * (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
   | Missing_native_external
   | Unbound_type_var of type_expr * type_declaration
   | Unbound_exception of Longident.t
   | Not_an_exception of Longident.t
-  | Bad_variance of int * (bool * bool) * (bool * bool)
+  | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool)
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
@@ -59,7 +57,7 @@ let enter_type env (name, sdecl) id =
       type_manifest =
         begin match sdecl.ptype_manifest with None -> None
         | Some _ -> Some(Ctype.newvar ()) end;
-      type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
+      type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
       type_newtype_level = None;
       type_loc = sdecl.ptype_loc;
     }
@@ -74,7 +72,7 @@ let update_type temp_env env id loc =
       let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
       try Ctype.unify env (Ctype.newconstr path params) ty
       with Ctype.Unify trace ->
-        raise (Error(loc, Type_clash trace))
+        raise (Error(loc, Type_clash (env, trace)))
 
 (* Determine if a type is (an abbreviation for) the type "float" *)
 (* We use the Ctype.expand_head_opt version of expand_head to get access
@@ -122,7 +120,7 @@ let set_fixed_row env loc p decl =
 module StringSet =
   Set.Make(struct
     type t = string
-    let compare = compare
+    let compare (x:t) y = compare x y
   end)
 
 let make_params sdecl =
@@ -165,7 +163,8 @@ let transl_declaration env (name, sdecl) id =
           let name = Ident.create lid.txt in
           match ret_type with
             | None ->
-              (name, lid, List.map (transl_simple_type env true) args, None, loc)
+              (name, lid, List.map (transl_simple_type env true) args,
+               None, loc)
             | Some sty ->
               (* if it's a generalized constructor we must first narrow and
                  then widen so as to not introduce any new constraints *)
@@ -229,7 +228,7 @@ let transl_declaration env (name, sdecl) id =
         type_kind = kind;
         type_private = sdecl.ptype_private;
         type_manifest = man;
-        type_variance = List.map (fun _ -> true, true, true) params;
+        type_variance = List.map (fun _ -> Variance.full) params;
         type_newtype_level = None;
         type_loc = sdecl.ptype_loc;
       } in
@@ -240,7 +239,7 @@ let transl_declaration env (name, sdecl) id =
         let ty = cty.ctyp_type in
         let ty' = cty'.ctyp_type in
         try Ctype.unify env ty ty' with Ctype.Unify tr ->
-          raise(Error(loc, Inconsistent_constraint tr)))
+          raise(Error(loc, Inconsistent_constraint (env, tr))))
       cstrs;
     Ctype.end_def ();
   (* Add abstract row *)
@@ -315,23 +314,28 @@ let rec check_constraints_rec env loc visited ty =
       Btype.iter_type_expr (check_constraints_rec env loc visited) ty
   end
 
+module SMap = Map.Make(String)
+
 let check_constraints env (_, sdecl) (_, decl) =
   let visited = ref TypeSet.empty in
   begin match decl.type_kind with
   | Type_abstract -> ()
   | Type_variant l ->
-      let rec find_pl = function
+      let find_pl = function
           Ptype_variant pl -> pl
         | Ptype_record _ | Ptype_abstract -> assert false
       in
       let pl = find_pl sdecl.ptype_kind in
+      let pl_index =
+        let foldf acc (name, styl, sret_type, _) =
+          SMap.add name.txt (styl, sret_type) acc
+        in
+        List.fold_left foldf SMap.empty pl
+      in
       List.iter
         (fun (name, tyl, ret_type) ->
           let (styl, sret_type) =
-            try
-              let (_, sty, sret_type, _) =
-                List.find (fun (n,_,_,_) -> n.txt = Ident.name name)  pl
-              in (sty, sret_type)
+            try SMap.find (Ident.name name) pl_index
             with Not_found -> assert false in
           List.iter2
             (fun sty ty ->
@@ -344,7 +348,7 @@ let check_constraints env (_, sdecl) (_, decl) =
               () )
         l
   | Type_record (l, _) ->
-      let rec find_pl = function
+      let find_pl = function
           Ptype_record pl -> pl
         | Ptype_variant _ | Ptype_abstract -> assert false
       in
@@ -373,7 +377,7 @@ let check_constraints env (_, sdecl) (_, decl) =
    need to check that the equation refers to a type of the same kind
    with the same constructors and labels.
 *)
-let check_abbrev env (_, sdecl) (id, decl) =
+let check_coherence env loc id decl =
   match decl with
     {type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} ->
       begin match (Ctype.repr ty).desc with
@@ -394,14 +398,17 @@ let check_abbrev env (_, sdecl) (id, decl) =
                      (Subst.add_type id path Subst.identity) decl)
             in
             if err <> [] then
-              raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, err)))
+              raise(Error(loc, Definition_mismatch (ty, err)))
           with Not_found ->
-            raise(Error(sdecl.ptype_loc, Unavailable_type_constructor path))
+            raise(Error(loc, Unavailable_type_constructor path))
           end
-      | _ -> raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, [])))
+      | _ -> raise(Error(loc, Definition_mismatch (ty, [])))
       end
   | _ -> ()
 
+let check_abbrev env (_, sdecl) (id, decl) =
+  check_coherence env sdecl.ptype_loc id decl
+
 (* Check that recursion is well-founded *)
 
 let check_well_founded env loc path decl =
@@ -410,7 +417,7 @@ let check_well_founded env loc path decl =
       try Ctype.correct_abbrev env path decl.type_params body with
       | Ctype.Recursive_abbrev ->
           raise(Error(loc, Recursive_abbrev (Path.name path)))
-      | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)))
+      | Ctype.Unify trace -> raise(Error(loc, Type_clash (env, trace))))
     decl.type_manifest
 
 (* Check for ill-defined abbrevs *)
@@ -478,77 +485,91 @@ let check_abbrev_recursion env id_loc_list (id, _, tdecl) =
 
 (* Compute variance *)
 
-let compute_variance env tvl nega posi cntr ty =
-  let pvisited = ref TypeSet.empty
-  and nvisited = ref TypeSet.empty
-  and cvisited = ref TypeSet.empty in
-  let rec compute_variance_rec posi nega cntr ty =
+module TypeMap = Btype.TypeMap
+
+let get_variance ty visited =
+  try TypeMap.find ty !visited with Not_found -> Variance.null
+
+let compute_variance env visited vari ty =
+  let rec compute_variance_rec vari ty =
+    (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *)
     let ty = Ctype.repr ty in
-    if (not posi || TypeSet.mem ty !pvisited)
-    && (not nega || TypeSet.mem ty !nvisited)
-    && (not cntr || TypeSet.mem ty !cvisited) then
-      ()
-    else begin
-      if posi then pvisited := TypeSet.add ty !pvisited;
-      if nega then nvisited := TypeSet.add ty !nvisited;
-      if cntr then cvisited := TypeSet.add ty !cvisited;
-      let compute_same = compute_variance_rec posi nega cntr in
-      match ty.desc with
-        Tarrow (_, ty1, ty2, _) ->
-          compute_variance_rec nega posi true ty1;
-          compute_same ty2
-      | Ttuple tl ->
-          List.iter compute_same tl
-      | Tconstr (path, tl, _) ->
-          if tl = [] then () else begin
-            try
-              let decl = Env.find_type path env in
-              List.iter2
-                (fun ty (co,cn,ct) ->
-                  compute_variance_rec
-                    (posi && co || nega && cn)
-                    (posi && cn || nega && co)
-                    (cntr || ct)
-                    ty)
-                tl decl.type_variance
-            with Not_found ->
-              List.iter (compute_variance_rec true true true) tl
-          end
-      | Tobject (ty, _) ->
-          compute_same ty
-      | Tfield (_, _, ty1, ty2) ->
-          compute_same ty1;
-          compute_same ty2
-      | Tsubst ty ->
-          compute_same ty
-      | Tvariant row ->
-          let row = Btype.row_repr row in
-          List.iter
-            (fun (_,f) ->
-              match Btype.row_field_repr f with
-                Rpresent (Some ty) ->
-                  compute_same ty
-              | Reither (_, tyl, _, _) ->
-                  List.iter compute_same tyl
-              | _ -> ())
-            row.row_fields;
-          compute_same row.row_more
-      | Tpoly (ty, _) ->
-          compute_same ty
-      | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
-      | Tpackage (_, _, tyl) ->
-          List.iter (compute_variance_rec true true true) tyl
-    end
+    let vari' = get_variance ty visited in
+    if Variance.subset vari vari' then () else
+    let vari = Variance.union vari vari' in
+    visited := TypeMap.add ty vari !visited;
+    let compute_same = compute_variance_rec vari in
+    match ty.desc with
+      Tarrow (_, ty1, ty2, _) ->
+        let open Variance in
+        let v = conjugate vari in
+        let v1 =
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
+        in
+        compute_variance_rec v1 ty1;
+        compute_same ty2
+    | Ttuple tl ->
+        List.iter compute_same tl
+    | Tconstr (path, tl, _) ->
+        let open Variance in
+        if tl = [] then () else begin
+          try
+            let decl = Env.find_type path env in
+            let cvari f = mem f vari in
+            List.iter2
+              (fun ty v ->
+                let cv f = mem f v in
+                let strict =
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
+                in
+                if strict then compute_variance_rec full ty else
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
+                let v1 =
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
+                and weak =
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
+                in
+                let v2 = set May_weak weak v1 in
+                compute_variance_rec v2 ty)
+              tl decl.type_variance
+          with Not_found ->
+            List.iter (compute_variance_rec may_inv) tl
+        end
+    | Tobject (ty, _) ->
+        compute_same ty
+    | Tfield (_, _, ty1, ty2) ->
+        compute_same ty1;
+        compute_same ty2
+    | Tsubst ty ->
+        compute_same ty
+    | Tvariant row ->
+        let row = Btype.row_repr row in
+        List.iter
+          (fun (_,f) ->
+            match Btype.row_field_repr f with
+              Rpresent (Some ty) ->
+                compute_same ty
+            | Reither (_, tyl, _, _) ->
+                List.iter compute_same tyl
+            | _ -> ())
+          row.row_fields;
+        compute_same row.row_more
+    | Tpoly (ty, _) ->
+        compute_same ty
+    | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+    | Tpackage (_, _, tyl) ->
+        let v =
+          Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
+        in
+        List.iter (compute_variance_rec v) tyl
   in
-  compute_variance_rec nega posi cntr ty;
-  List.iter
-    (fun (ty, covar, convar, ctvar) ->
-      if TypeSet.mem ty !pvisited then covar := true;
-      if TypeSet.mem ty !nvisited then convar := true;
-      if TypeSet.mem ty !cvisited then ctvar := true)
-    tvl
+  compute_variance_rec vari ty
 
-let make_variance ty = (ty, ref false, ref false, ref false)
+let make_variance ty = (ty, ref Variance.null)
 let whole_type decl =
   match decl.type_kind with
     Type_variant tll ->
@@ -562,49 +583,101 @@ let whole_type decl =
         Some ty -> ty
       | _ -> Btype.newgenty (Ttuple [])
 
+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 compute_variance_type env check (required, loc) decl tyl =
-  let params = List.map Btype.repr decl.type_params in
-  let tvl0 = List.map make_variance params in
-  let args = Btype.newgenty (Ttuple params) in
-  let fvl = if check then Ctype.free_variables args else [] in
-  let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
-  let tvl1 = List.map make_variance fvl in
-  let tvl2 = List.map make_variance fvl in
-  let tvl = tvl0 @ tvl1 in
-  List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl;
+  (* Requirements *)
   let required =
-    List.map (fun (c,n as r) -> if c || n then r else (true,true))
+    List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
       required
   in
-  List.iter2
-    (fun (ty, co, cn, ct) (c, n) ->
-      if not (Btype.is_Tvar ty) then begin
-        co := c; cn := n; ct := n;
-        compute_variance env tvl2 c n n ty
-      end)
-    tvl0 required;
-  List.iter2
-    (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
-      if !c1 && not !c2 || !n1 && not !n2
-      then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
-    tvl1 tvl2;
-  let pos = ref 0 in
+  (* Prepare *)
+  let params = List.map Btype.repr decl.type_params in
+  let tvl = ref TypeMap.empty in
+  (* Compute occurences in body *)
+  let open Variance in
+  List.iter
+    (fun (cn,ty) ->
+      compute_variance env tvl (if cn then full else covariant) ty)
+    tyl;
+  if check then begin
+    (* Check variance of parameters *)
+    let pos = ref 0 in
+    List.iter2
+      (fun ty (c, n, i) ->
+        incr pos;
+        let var = get_variance ty tvl in
+        let (co,cn) = get_upper var and ij = mem Inj var in
+        if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
+        then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i)))))
+      params required;
+    (* Check propagation from constrained parameters *)
+    let args = Btype.newgenty (Ttuple params) in
+    let fvl = Ctype.free_variables args in
+    let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+    (* If there are no extra variables there is nothing to do *)
+    if fvl = [] then () else
+    let tvl2 = ref TypeMap.empty in
+    List.iter2
+      (fun ty (p,n,i) ->
+        if Btype.is_Tvar ty then () else
+        let v =
+          if p then if n then full else covariant else conjugate covariant in
+        compute_variance env tvl2 v ty)
+      params required;
+    let visited = ref TypeSet.empty in
+    let rec check ty =
+      let ty = Ctype.repr ty in
+      if TypeSet.mem ty !visited then () else
+      let visited' = TypeSet.add ty !visited in
+      visited := visited';
+      let v1 = get_variance ty tvl in
+      let snap = Btype.snapshot () in
+      let v2 =
+        TypeMap.fold
+          (fun t vt v ->
+            if Ctype.equal env false [ty] [t] then union vt v else v)
+          !tvl2 null in
+      Btype.backtrack snap;
+      let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in
+      if c1 && not c2 || n1 && not n2 then
+        if List.memq ty fvl then
+          let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in
+          raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false))))
+        else
+          Btype.iter_type_expr check ty
+    in
+    List.iter (fun (_,ty) -> check ty) tyl;
+  end;
   List.map2
-    (fun (_, co, cn, ct) (c, n) ->
-      incr pos;
-      if !co && not c || !cn && not n
-      then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n))));
-      if decl.type_private = Private then (c,n,n) else
-      let ct = if decl.type_kind = Type_abstract then ct else cn in
-      (!co, !cn, !ct))
-    tvl0 required
+    (fun ty (p, n, i) ->
+      let v = get_variance ty tvl in
+      let tr = decl.type_private in
+      (* Use required variance where relevant *)
+      let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in
+      let (p, n) =
+        if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *)
+        else (false, false) (* only check *)
+      and i = concr  || i && tr = Private in
+      let v = union v (make p n i) in
+      let v =
+        if not concr then v else
+        if mem Pos v && mem Neg v then full else
+        if Btype.is_Tvar ty then v else
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
+      in
+      if decl.type_kind = Type_abstract && tr = Public then v else
+      set May_weak (mem May_neg v) v)
+    params required
 
 let add_false = List.map (fun ty -> false, ty)
 
 (* A parameter is constrained if either is is instantiated,
    or it is a variable appearing in another parameter *)
 let constrained env vars ty =
-  let ty = Ctype.expand_head env ty in
   match ty.desc with
   | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
   | _ -> true
@@ -618,10 +691,12 @@ let compute_variance_gadt env check (required, loc as rloc) decl
   | Some ret_type ->
       match Ctype.repr ret_type with
       | {desc=Tconstr (path, tyl, _)} ->
+          (* let tyl = List.map (Ctype.expand_head env) tyl in *)
+          let tyl = List.map Ctype.repr tyl in
           let fvl = List.map Ctype.free_variables tyl in
           let _ =
             List.fold_left2
-              (fun (fv1,fv2) ty (c,n) ->
+              (fun (fv1,fv2) ty (c,n,i) ->
                 match fv2 with [] -> assert false
                 | fv :: fv2 ->
                     (* fv1 @ fv2 = free_variables of other parameters *)
@@ -637,26 +712,38 @@ let compute_variance_gadt env check (required, loc as rloc) decl
 
 let compute_variance_decl env check decl (required, loc as rloc) =
   if decl.type_kind = Type_abstract && decl.type_manifest = None then
-    List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
+    List.map
+      (fun (c, n, i) ->
+        make (not n) (not c) (i (*|| decl.type_transparence = Type_new*)))
       required
-  else match decl.type_kind with
-  | Type_abstract ->
-      begin match decl.type_manifest with
-        None -> assert false
-      | Some ty -> compute_variance_type env check rloc decl [false, ty]
-      end
+  else
+  let mn =
+    match decl.type_manifest with
+      None -> []
+    | Some ty -> [false, ty]
+  in
+  match decl.type_kind with
+    Type_abstract ->
+      compute_variance_type env check rloc decl mn
   | Type_variant tll ->
       if List.for_all (fun (_,_,ret) -> ret = None) tll then
         compute_variance_type env check rloc decl
-          (add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll)))
+          (mn @ add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll)))
       else begin
+        let mn =
+          List.map (fun (_,ty) -> (Ident.create_persistent"",[ty],None)) mn in
+        let tll = mn @ tll in
         match List.map (compute_variance_gadt env check rloc decl) tll with
-        | vari :: _ -> vari
+        | vari :: rem ->
+            let varl = List.fold_left (List.map2 Variance.union) vari rem in
+            List.map
+              Variance.(fun v -> if mem Pos v && mem Neg v then full else v)
+              varl
         | _ -> assert false
       end
   | Type_record (ftl, _) ->
       compute_variance_type env check rloc decl
-        (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
+        (mn @ List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
 
 let is_sharp id =
   let s = Ident.name id in
@@ -678,12 +765,17 @@ let rec compute_variance_fixpoint env decls required variances =
       new_decls required
   in
   let new_variances =
-    List.map2
-      (List.map2 (fun (c1,n1,t1) (c2,n2,t2) -> c1||c2, n1||n2, t1||t2))
-      new_variances variances in
+    List.map2 (List.map2 Variance.union) new_variances variances in
   if new_variances <> variances then
     compute_variance_fixpoint env decls required new_variances
   else begin
+    (* List.iter (fun (id, decl) ->
+      Printf.eprintf "%s:" (Ident.name id);
+      List.iter (fun (v : Variance.t) ->
+        Printf.eprintf " %x" (Obj.magic v : int))
+        decl.type_variance;
+      prerr_endline "")
+      new_decls; *)
     List.iter2
       (fun (id, decl) req -> if not (is_sharp id) then
         ignore (compute_variance_decl new_env true decl req))
@@ -692,22 +784,25 @@ let rec compute_variance_fixpoint env decls required variances =
   end
 
 let init_variance (id, decl) =
-  List.map (fun _ -> (false, false, false)) decl.type_params
+  List.map (fun _ -> Variance.null) decl.type_params
+
+let add_injectivity = List.map (fun (cn,cv) -> (cn,cv,false))
 
 (* for typeclass.ml *)
 let compute_variance_decls env cldecls =
   let decls, required =
     List.fold_right
       (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) ->
-        (obj_id, obj_abbr) :: decls, (ci.ci_variance, ci.ci_loc) :: req)
+        (obj_id, obj_abbr) :: decls,
+        (add_injectivity ci.ci_variance, ci.ci_loc) :: req)
       cldecls ([],[])
   in
   let variances = List.map init_variance decls in
   let (decls, _) = compute_variance_fixpoint env decls required variances in
   List.map2
     (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
-      let variance = List.map (fun (c,n,t) -> (c,n)) decl.type_variance in
-      (decl, {cl_abbr with type_variance = decl.type_variance},
+      let variance = decl.type_variance in
+      (decl, {cl_abbr with type_variance = variance},
        {clty with cty_variance = variance},
        {cltydef with clty_variance = variance}))
     decls cldecls
@@ -846,8 +941,6 @@ let transl_type_decl env name_sdecl_list =
          Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
        | None   -> ())
     name_sdecl_list tdecls;
-  (* Check re-exportation *)
-  List.iter2 (check_abbrev newenv) name_sdecl_list decls;
   (* Check that constraints are enforced *)
   List.iter2 (check_constraints newenv) name_sdecl_list decls;
   (* Name recursion *)
@@ -858,12 +951,16 @@ let transl_type_decl env name_sdecl_list =
   in
   (* Add variances to the environment *)
   let required =
-    List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
+    List.map
+      (fun (_, sdecl) -> add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)
       name_sdecl_list
   in
   let final_decls, final_env =
     compute_variance_fixpoint env decls required (List.map init_variance decls)
   in
+  (* Check re-exportation *)
+  List.iter2 (check_abbrev final_env) name_sdecl_list final_decls;
+  (* Keep original declaration *)
   let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) ->
         (id, name_loc, { tdecl with typ_type = decl })
     ) tdecls final_decls in
@@ -893,7 +990,7 @@ let transl_exception env loc excdecl =
 
 (* Translate an exception rebinding *)
 let transl_exn_rebind env loc lid =
-  let (path, cdescr) =
+  let cdescr =
     try
       Env.lookup_constructor lid env
     with Not_found ->
@@ -948,7 +1045,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
          Ctype.unify env ty ty';
          (cty, cty', loc)
        with Ctype.Unify tr ->
-         raise(Error(loc, Inconsistent_constraint tr)))
+         raise(Error(loc, Inconsistent_constraint (env, tr))))
     sdecl.ptype_cstrs
   in
   let no_row = not (is_fixed_type sdecl) in
@@ -958,11 +1055,16 @@ let transl_with_constraint env id row_path orig_decl sdecl =
         let cty = transl_simple_type env no_row sty in
         Some cty, Some cty.ctyp_type
   in
+  let priv =
+    if sdecl.ptype_private = Private then Private else
+    if arity_ok && orig_decl.type_kind <> Type_abstract
+    then orig_decl.type_private else sdecl.ptype_private
+  in
   let decl =
     { type_params = params;
       type_arity = List.length params;
       type_kind = if arity_ok then orig_decl.type_kind else Type_abstract;
-      type_private = sdecl.ptype_private;
+      type_private = priv;
       type_manifest = man;
       type_variance = [];
       type_newtype_level = None;
@@ -979,7 +1081,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
   let decl =
     {decl with type_variance =
      compute_variance_decl env false decl
-       (sdecl.ptype_variance, sdecl.ptype_loc)} in
+       (add_injectivity sdecl.ptype_variance, sdecl.ptype_loc)} in
   Ctype.end_def();
   generalize_decl decl;
   {
@@ -1005,7 +1107,7 @@ let abstract_type_decl arity =
       type_kind = Type_abstract;
       type_private = Public;
       type_manifest = None;
-      type_variance = replicate_list (true, true, true) arity;
+      type_variance = replicate_list Variance.full arity;
       type_newtype_level = None;
       type_loc = Location.none;
      } in
@@ -1099,13 +1201,13 @@ let report_error ppf = function
       fprintf ppf
         "@[In the definition of %s, type@ %a@ should be@ %a@]"
         (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
-  | Inconsistent_constraint trace ->
+  | Inconsistent_constraint (env, trace) ->
       fprintf ppf "The type constraints are not consistent.@.";
-      Printtyp.report_unification_error ppf trace
+      Printtyp.report_unification_error ppf env trace
         (fun ppf -> fprintf ppf "Type")
         (fun ppf -> fprintf ppf "is not compatible with type")
-  | Type_clash trace ->
-      Printtyp.report_unification_error ppf trace
+  | Type_clash (env, trace) ->
+      Printtyp.report_unification_error ppf env trace
         (function ppf ->
            fprintf ppf "This type constructor expands to type")
         (function ppf ->
@@ -1140,11 +1242,13 @@ let report_error ppf = function
       fprintf ppf "The constructor@ %a@ is not an exception"
         Printtyp.longident lid
   | Bad_variance (n, v1, v2) ->
-      let variance = function
-          (true, true)  -> "invariant"
-        | (true, false) -> "covariant"
-        | (false,true)  -> "contravariant"
-        | (false,false) -> "unrestricted"
+      let variance (p,n,i) =
+        let inj = if i then "injective " else "" in
+        match p, n with
+          true,  true  -> inj ^ "invariant"
+        | true,  false -> inj ^ "covariant"
+        | false, true  -> inj ^ "contravariant"
+        | false, false -> if inj = "" then "unrestricted" else inj
       in
       let suffix n =
         let teen = (n mod 100)/10 = 1 in
@@ -1154,17 +1258,26 @@ let report_error ppf = function
         | 3 when not teen -> "rd"
         | _ -> "th"
       in
-      if n < 1 then
-        fprintf ppf "@[%s@ %s@]"
+      if n = -1 then
+        fprintf ppf "@[%s@ %s@ It"
           "In this definition, a type variable has a variance that"
           "is not reflected by its occurrence in type parameters."
+      else if n = -2 then
+        fprintf ppf "@[%s@ %s@]"
+          "In this definition, a type variable cannot be deduced"
+          "from the type parameters."
+      else if n = -3 then
+        fprintf ppf "@[%s@ %s@ It"
+          "In this definition, a type variable has a variance that"
+          "cannot be deduced from the type parameters."
       else
-        fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]"
+        fprintf ppf "@[%s@ %s@ The %d%s type parameter"
           "In this definition, expected parameter"
           "variances are not satisfied."
-          "The" n (suffix n)
-          "type parameter was expected to be" (variance v2)
-          "but it is" (variance v1)
+          n (suffix n);
+      if n <> -2 then
+        fprintf ppf " was expected to be %s,@ but it is %s.@]"
+          (variance v2) (variance v1)
   | Unavailable_type_constructor p ->
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
   | Bad_fixed_type r ->
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 98d44fac..869438e6 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedecl.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
 (* Typing of type definitions and primitive definitions *)
 
 open Asttypes
@@ -43,6 +41,8 @@ val approx_type_decl:
                                   (Ident.t * type_declaration) list
 val check_recmod_typedecl:
     Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
+val check_coherence:
+    Env.t -> Location.t -> Ident.t -> type_declaration -> unit
 
 (* for fixed types *)
 val is_fixed_type : Parsetree.type_declaration -> bool
@@ -64,15 +64,15 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Inconsistent_constraint of (type_expr * type_expr) list
-  | Type_clash of (type_expr * type_expr) list
+  | Inconsistent_constraint of Env.t * (type_expr * type_expr) list
+  | Type_clash of Env.t * (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
   | Missing_native_external
   | Unbound_type_var of type_expr * type_declaration
   | Unbound_exception of Longident.t
   | Not_an_exception of Longident.t
-  | Bad_variance of int * (bool*bool) * (bool*bool)
+  | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool)
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index c3ba3b71..405e56bd 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedtree.ml 12681 2012-07-10 08:33:16Z garrigue $ *)
-
 (* Abstract syntax tree after typing *)
 
 open Misc
@@ -42,10 +40,10 @@ and pattern_desc =
   | Tpat_constant of constant
   | Tpat_tuple of pattern list
   | Tpat_construct of
-      Path.t * Longident.t loc * constructor_description * pattern list * bool
+      Longident.t loc * constructor_description * pattern list * bool
   | Tpat_variant of label * pattern option * row_desc ref
   | Tpat_record of
-      (Path.t * Longident.t loc * label_description * pattern) list *
+      (Longident.t loc * label_description * pattern) list *
         closed_flag
   | Tpat_array of pattern list
   | Tpat_or of pattern * pattern * row_desc option
@@ -60,7 +58,7 @@ and expression =
 
 and exp_extra =
   | Texp_constraint of core_type option * core_type option
-  | Texp_open of Path.t * Longident.t loc * Env.t
+  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
   | Texp_poly of core_type option
   | Texp_newtype of string
 
@@ -74,15 +72,15 @@ and expression_desc =
   | Texp_try of expression * (pattern * expression) list
   | Texp_tuple of expression list
   | Texp_construct of
-      Path.t * Longident.t loc * constructor_description * expression list *
+      Longident.t loc * constructor_description * expression list *
         bool
   | Texp_variant of label * expression option
   | Texp_record of
-      (Path.t * Longident.t loc * label_description * expression) list *
+      (Longident.t loc * label_description * expression) list *
         expression option
-  | Texp_field of expression * Path.t * Longident.t loc * label_description
+  | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
-      expression * Path.t * Longident.t loc * label_description * expression
+      expression * Longident.t loc * label_description * expression
   | Texp_array of expression list
   | Texp_ifthenelse of expression * expression * expression option
   | Texp_sequence of expression * expression
@@ -201,10 +199,10 @@ and structure_item_desc =
   | Tstr_module of Ident.t * string loc * module_expr
   | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
   | Tstr_modtype of Ident.t * string loc * module_type
-  | Tstr_open of Path.t * Longident.t loc
+  | Tstr_open of override_flag * Path.t * Longident.t loc
   | Tstr_class of (class_declaration * string list * virtual_flag) list
   | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
-  | Tstr_include of module_expr * Ident.t list
+  | Tstr_include of module_expr * Types.signature
 
 and module_coercion =
     Tcoerce_none
@@ -243,7 +241,7 @@ and signature_item_desc =
   | Tsig_module of Ident.t * string loc * module_type
   | Tsig_recmodule of (Ident.t * string loc * module_type) list
   | Tsig_modtype of Ident.t * string loc * modtype_declaration
-  | Tsig_open of Path.t * Longident.t loc
+  | Tsig_open of override_flag * Path.t * Longident.t loc
   | Tsig_include of module_type * Types.signature
   | Tsig_class of class_description list
   | Tsig_class_type of class_type_declaration list
@@ -383,10 +381,10 @@ and 'a class_infos =
 let iter_pattern_desc f = function
   | Tpat_alias(p, _, _) -> f p
   | Tpat_tuple patl -> List.iter f patl
-  | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl
+  | Tpat_construct(_, cstr, patl, _) -> List.iter f patl
   | Tpat_variant(_, pat, _) -> may f pat
   | Tpat_record (lbl_pat_list, _) ->
-      List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list
+      List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
   | Tpat_array patl -> List.iter f patl
   | Tpat_or(p1, p2, _) -> f p1; f p2
   | Tpat_lazy p -> f p
@@ -401,10 +399,9 @@ let map_pattern_desc f d =
   | Tpat_tuple pats ->
       Tpat_tuple (List.map f pats)
   | Tpat_record (lpats, closed) ->
-      Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p)
-                     lpats, closed)
-  | Tpat_construct (lid, lid_loc, c,pats, arity) ->
-      Tpat_construct (lid, lid_loc, c, List.map f pats, arity)
+      Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
+  | Tpat_construct (lid, c,pats, arity) ->
+      Tpat_construct (lid, c, List.map f pats, arity)
   | Tpat_array pats ->
       Tpat_array (List.map f pats)
   | Tpat_lazy p1 -> Tpat_lazy (f p1)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 38b5e258..a263c909 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typedtree.mli 12681 2012-07-10 08:33:16Z garrigue $ *)
-
 (* Abstract syntax tree after typing *)
 
 open Asttypes
@@ -41,10 +39,10 @@ and pattern_desc =
   | Tpat_constant of constant
   | Tpat_tuple of pattern list
   | Tpat_construct of
-      Path.t * Longident.t loc * constructor_description * pattern list * bool
+      Longident.t loc * constructor_description * pattern list * bool
   | Tpat_variant of label * pattern option * row_desc ref
   | Tpat_record of
-      (Path.t * Longident.t loc * label_description * pattern) list *
+      (Longident.t loc * label_description * pattern) list *
         closed_flag
   | Tpat_array of pattern list
   | Tpat_or of pattern * pattern * row_desc option
@@ -59,7 +57,7 @@ and expression =
 
 and exp_extra =
   | Texp_constraint of core_type option * core_type option
-  | Texp_open of Path.t * Longident.t loc * Env.t
+  | Texp_open of override_flag * Path.t * Longident.t loc * Env.t
   | Texp_poly of core_type option
   | Texp_newtype of string
 
@@ -73,15 +71,15 @@ and expression_desc =
   | Texp_try of expression * (pattern * expression) list
   | Texp_tuple of expression list
   | Texp_construct of
-      Path.t * Longident.t loc * constructor_description * expression list *
+      Longident.t loc * constructor_description * expression list *
         bool
   | Texp_variant of label * expression option
   | Texp_record of
-      (Path.t * Longident.t loc * label_description * expression) list *
+      (Longident.t loc * label_description * expression) list *
         expression option
-  | Texp_field of expression * Path.t * Longident.t loc * label_description
+  | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
-      expression * Path.t * Longident.t loc * label_description * expression
+      expression * Longident.t loc * label_description * expression
   | Texp_array of expression list
   | Texp_ifthenelse of expression * expression * expression option
   | Texp_sequence of expression * expression
@@ -200,10 +198,10 @@ and structure_item_desc =
   | Tstr_module of Ident.t * string loc * module_expr
   | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list
   | Tstr_modtype of Ident.t * string loc * module_type
-  | Tstr_open of Path.t * Longident.t loc
+  | Tstr_open of override_flag * Path.t * Longident.t loc
   | Tstr_class of (class_declaration * string list * virtual_flag) list
   | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
-  | Tstr_include of module_expr * Ident.t list
+  | Tstr_include of module_expr * Types.signature
 
 and module_coercion =
     Tcoerce_none
@@ -242,7 +240,7 @@ and signature_item_desc =
   | Tsig_module of Ident.t * string loc * module_type
   | Tsig_recmodule of (Ident.t * string loc * module_type) list
   | Tsig_modtype of Ident.t * string loc * modtype_declaration
-  | Tsig_open of Path.t * Longident.t loc
+  | Tsig_open of override_flag * Path.t * Longident.t loc
   | Tsig_include of module_type * Types.signature
   | Tsig_class of class_description list
   | Tsig_class_type of class_type_declaration list
@@ -384,7 +382,6 @@ val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc
 
 val let_bound_idents: (pattern * expression) list -> Ident.t list
 val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
-val pat_bound_idents: pattern -> Ident.t list
 
 val let_bound_idents_with_loc:
     (pattern * expression) list -> (Ident.t * string loc) list
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
new file mode 100644
index 00000000..42808266
--- /dev/null
+++ b/typing/typedtreeIter.ml
@@ -0,0 +1,642 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*   en Automatique.  All rights reserved.  This file is distributed      *)
+(*   under the terms of the Q Public License version 1.0.                 *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*
+TODO:
+ - 2012/05/10: Follow camlp4 way of building map and iter using classes
+     and inheritance ?
+*)
+
+open Asttypes
+open Typedtree
+
+module type IteratorArgument = sig
+
+    val enter_structure : structure -> unit
+    val enter_value_description : value_description -> unit
+    val enter_type_declaration : type_declaration -> unit
+    val enter_exception_declaration :
+      exception_declaration -> unit
+    val enter_pattern : pattern -> unit
+    val enter_expression : expression -> unit
+    val enter_package_type : package_type -> unit
+    val enter_signature : signature -> unit
+    val enter_signature_item : signature_item -> unit
+    val enter_modtype_declaration : modtype_declaration -> unit
+    val enter_module_type : module_type -> unit
+    val enter_module_expr : module_expr -> unit
+    val enter_with_constraint : with_constraint -> unit
+    val enter_class_expr : class_expr -> unit
+    val enter_class_signature : class_signature -> unit
+    val enter_class_declaration : class_declaration -> unit
+    val enter_class_description : class_description -> unit
+    val enter_class_type_declaration : class_type_declaration -> unit
+    val enter_class_type : class_type -> unit
+    val enter_class_type_field : class_type_field -> unit
+    val enter_core_type : core_type -> unit
+    val enter_core_field_type : core_field_type -> unit
+    val enter_class_structure : class_structure -> unit
+    val enter_class_field : class_field -> unit
+    val enter_structure_item : structure_item -> unit
+
+
+    val leave_structure : structure -> unit
+    val leave_value_description : value_description -> unit
+    val leave_type_declaration : type_declaration -> unit
+    val leave_exception_declaration :
+      exception_declaration -> unit
+    val leave_pattern : pattern -> unit
+    val leave_expression : expression -> unit
+    val leave_package_type : package_type -> unit
+    val leave_signature : signature -> unit
+    val leave_signature_item : signature_item -> unit
+    val leave_modtype_declaration : modtype_declaration -> unit
+    val leave_module_type : module_type -> unit
+    val leave_module_expr : module_expr -> unit
+    val leave_with_constraint : with_constraint -> unit
+    val leave_class_expr : class_expr -> unit
+    val leave_class_signature : class_signature -> unit
+    val leave_class_declaration : class_declaration -> unit
+    val leave_class_description : class_description -> unit
+    val leave_class_type_declaration : class_type_declaration -> unit
+    val leave_class_type : class_type -> unit
+    val leave_class_type_field : class_type_field -> unit
+    val leave_core_type : core_type -> unit
+    val leave_core_field_type : core_field_type -> unit
+    val leave_class_structure : class_structure -> unit
+    val leave_class_field : class_field -> unit
+    val leave_structure_item : structure_item -> unit
+
+    val enter_bindings : rec_flag -> unit
+    val enter_binding : pattern -> expression -> unit
+    val leave_binding : pattern -> expression -> unit
+    val leave_bindings : rec_flag -> unit
+
+      end
+
+module MakeIterator(Iter : IteratorArgument) : sig
+
+    val iter_structure : structure -> unit
+    val iter_signature : signature -> unit
+    val iter_structure_item : structure_item -> unit
+    val iter_signature_item : signature_item -> unit
+    val iter_expression : expression -> unit
+    val iter_module_type : module_type -> unit
+    val iter_pattern : pattern -> unit
+    val iter_class_expr : class_expr -> unit
+
+  end = struct
+
+    let may_iter f v =
+      match v with
+        None -> ()
+      | Some x -> f x
+
+
+    open Asttypes
+
+    let rec iter_structure str =
+      Iter.enter_structure str;
+      List.iter iter_structure_item str.str_items;
+      Iter.leave_structure str
+
+
+    and iter_binding (pat, exp) =
+      Iter.enter_binding pat exp;
+      iter_pattern pat;
+      iter_expression exp;
+      Iter.leave_binding pat exp
+
+    and iter_bindings rec_flag list =
+      Iter.enter_bindings rec_flag;
+      List.iter iter_binding list;
+      Iter.leave_bindings rec_flag
+
+    and iter_structure_item item =
+      Iter.enter_structure_item item;
+      begin
+        match item.str_desc with
+          Tstr_eval exp -> iter_expression exp
+        | Tstr_value (rec_flag, list) ->
+            iter_bindings rec_flag list
+        | Tstr_primitive (id, _, v) -> iter_value_description v
+        | Tstr_type list ->
+            List.iter (fun (id, _, decl) -> iter_type_declaration decl) list
+        | Tstr_exception (id, _, decl) -> iter_exception_declaration decl
+        | Tstr_exn_rebind (id, _, p, _) -> ()
+        | Tstr_module (id, _, mexpr) ->
+            iter_module_expr mexpr
+        | Tstr_recmodule list ->
+            List.iter (fun (id, _, mtype, mexpr) ->
+                iter_module_type mtype;
+                iter_module_expr mexpr) list
+        | Tstr_modtype (id, _, mtype) ->
+            iter_module_type mtype
+        | Tstr_open _ -> ()
+        | Tstr_class list ->
+            List.iter (fun (ci, _, _) ->
+                Iter.enter_class_declaration ci;
+                iter_class_expr ci.ci_expr;
+                Iter.leave_class_declaration ci;
+            ) list
+        | Tstr_class_type list ->
+            List.iter (fun (id, _, ct) ->
+                Iter.enter_class_type_declaration ct;
+                iter_class_type ct.ci_expr;
+                Iter.leave_class_type_declaration ct;
+            ) list
+        | Tstr_include (mexpr, _) ->
+            iter_module_expr mexpr
+      end;
+      Iter.leave_structure_item item
+
+    and iter_value_description v =
+      Iter.enter_value_description v;
+      iter_core_type v.val_desc;
+      Iter.leave_value_description v
+
+    and iter_type_declaration decl =
+      Iter.enter_type_declaration decl;
+      List.iter (fun (ct1, ct2, loc) ->
+          iter_core_type ct1;
+          iter_core_type ct2
+      ) decl.typ_cstrs;
+      begin match decl.typ_kind with
+          Ttype_abstract -> ()
+        | Ttype_variant list ->
+            List.iter (fun (s, _, cts, loc) ->
+                List.iter iter_core_type cts
+            ) list
+        | Ttype_record list ->
+            List.iter (fun (s, _, mut, ct, loc) ->
+                iter_core_type ct
+            ) list
+      end;
+      begin match decl.typ_manifest with
+          None -> ()
+        | Some ct -> iter_core_type ct
+      end;
+      Iter.leave_type_declaration decl
+
+    and iter_exception_declaration decl =
+      Iter.enter_exception_declaration decl;
+      List.iter iter_core_type decl.exn_params;
+      Iter.leave_exception_declaration decl;
+
+    and iter_pattern pat =
+      Iter.enter_pattern pat;
+      List.iter (fun (cstr, _) -> match cstr with
+              | Tpat_type _ -> ()
+              | Tpat_unpack -> ()
+              | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
+      begin
+        match pat.pat_desc with
+          Tpat_any -> ()
+        | Tpat_var (id, _) -> ()
+        | Tpat_alias (pat1, _, _) -> iter_pattern pat1
+        | Tpat_constant cst -> ()
+        | Tpat_tuple list ->
+            List.iter iter_pattern list
+        | Tpat_construct (_, _, args, _) ->
+            List.iter iter_pattern args
+        | Tpat_variant (label, pato, _) ->
+            begin match pato with
+                None -> ()
+              | Some pat -> iter_pattern pat
+            end
+        | Tpat_record (list, closed) ->
+            List.iter (fun (_, _, pat) -> iter_pattern pat) list
+        | Tpat_array list -> List.iter iter_pattern list
+        | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
+        | Tpat_lazy p -> iter_pattern p
+      end;
+      Iter.leave_pattern pat
+
+    and option f x = match x with None -> () | Some e -> f e
+
+    and iter_expression exp =
+      Iter.enter_expression exp;
+      List.iter (function (cstr, _) ->
+        match cstr with
+          Texp_constraint (cty1, cty2) ->
+            option iter_core_type cty1; option iter_core_type cty2
+        | Texp_open (_, path, _, _) -> ()
+        | Texp_poly cto -> option iter_core_type cto
+        | Texp_newtype s -> ())
+        exp.exp_extra;
+      begin
+        match exp.exp_desc with
+          Texp_ident (path, _, _) -> ()
+        | Texp_constant cst -> ()
+        | Texp_let (rec_flag, list, exp) ->
+            iter_bindings rec_flag list;
+            iter_expression exp
+        | Texp_function (label, cases, _) ->
+            iter_bindings Nonrecursive cases
+        | Texp_apply (exp, list) ->
+            iter_expression exp;
+            List.iter (fun (label, expo, _) ->
+                match expo with
+                  None -> ()
+                | Some exp -> iter_expression exp
+            ) list
+        | Texp_match (exp, list, _) ->
+            iter_expression exp;
+            iter_bindings Nonrecursive list
+        | Texp_try (exp, list) ->
+            iter_expression exp;
+            iter_bindings Nonrecursive list
+        | Texp_tuple list ->
+            List.iter iter_expression list
+        | Texp_construct (_, _, args, _) ->
+            List.iter iter_expression args
+        | Texp_variant (label, expo) ->
+            begin match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_record (list, expo) ->
+            List.iter (fun (_, _, exp) -> iter_expression exp) list;
+            begin match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_field (exp, _, label) ->
+            iter_expression exp
+        | Texp_setfield (exp1, _, label, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_array list ->
+            List.iter iter_expression list
+        | Texp_ifthenelse (exp1, exp2, expo) ->
+            iter_expression exp1;
+            iter_expression exp2;
+            begin match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+            end
+        | Texp_sequence (exp1, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_while (exp1, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_for (id, _, exp1, exp2, dir, exp3) ->
+            iter_expression exp1;
+            iter_expression exp2;
+            iter_expression exp3
+        | Texp_when (exp1, exp2) ->
+            iter_expression exp1;
+            iter_expression exp2
+        | Texp_send (exp, meth, expo) ->
+            iter_expression exp;
+          begin
+            match expo with
+                None -> ()
+              | Some exp -> iter_expression exp
+          end
+        | Texp_new (path, _, _) -> ()
+        | Texp_instvar (_, path, _) -> ()
+        | Texp_setinstvar (_, _, _, exp) ->
+            iter_expression exp
+        | Texp_override (_, list) ->
+            List.iter (fun (path, _, exp) ->
+                iter_expression exp
+            ) list
+        | Texp_letmodule (id, _, mexpr, exp) ->
+            iter_module_expr mexpr;
+            iter_expression exp
+        | Texp_assert exp -> iter_expression exp
+        | Texp_assertfalse -> ()
+        | Texp_lazy exp -> iter_expression exp
+        | Texp_object (cl, _) ->
+            iter_class_structure cl
+        | Texp_pack (mexpr) ->
+            iter_module_expr mexpr
+      end;
+      Iter.leave_expression exp;
+
+    and iter_package_type pack =
+      Iter.enter_package_type pack;
+      List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
+      Iter.leave_package_type pack;
+
+    and iter_signature sg =
+      Iter.enter_signature sg;
+      List.iter iter_signature_item sg.sig_items;
+      Iter.leave_signature sg;
+
+    and iter_signature_item item =
+      Iter.enter_signature_item item;
+      begin
+        match item.sig_desc with
+          Tsig_value (id, _, v) ->
+            iter_value_description v
+        | Tsig_type list ->
+            List.iter (fun (id, _, decl) ->
+                iter_type_declaration decl
+            ) list
+        | Tsig_exception (id, _, decl) ->
+            iter_exception_declaration decl
+        | Tsig_module (id, _, mtype) ->
+            iter_module_type mtype
+        | Tsig_recmodule list ->
+            List.iter (fun (id, _, mtype) -> iter_module_type mtype) list
+        | Tsig_modtype (id, _, mdecl) ->
+            iter_modtype_declaration mdecl
+        | Tsig_open _ -> ()
+        | Tsig_include (mty,_) -> iter_module_type mty
+        | Tsig_class list ->
+            List.iter iter_class_description list
+        | Tsig_class_type list ->
+            List.iter iter_class_type_declaration list
+      end;
+      Iter.leave_signature_item item;
+
+    and iter_modtype_declaration mdecl =
+      Iter.enter_modtype_declaration mdecl;
+      begin
+        match mdecl with
+          Tmodtype_abstract -> ()
+        | Tmodtype_manifest mtype -> iter_module_type mtype
+      end;
+      Iter.leave_modtype_declaration mdecl;
+
+
+    and iter_class_description cd =
+      Iter.enter_class_description cd;
+      iter_class_type cd.ci_expr;
+      Iter.leave_class_description cd;
+
+    and iter_class_type_declaration cd =
+      Iter.enter_class_type_declaration cd;
+      iter_class_type cd.ci_expr;
+        Iter.leave_class_type_declaration cd;
+
+    and iter_module_type mty =
+      Iter.enter_module_type mty;
+      begin
+        match mty.mty_desc with
+          Tmty_ident (path, _) -> ()
+        | Tmty_signature sg -> iter_signature sg
+        | Tmty_functor (id, _, mtype1, mtype2) ->
+            iter_module_type mtype1; iter_module_type mtype2
+        | Tmty_with (mtype, list) ->
+            iter_module_type mtype;
+            List.iter (fun (path, _, withc) ->
+                iter_with_constraint withc
+            ) list
+        | Tmty_typeof mexpr ->
+            iter_module_expr mexpr
+      end;
+      Iter.leave_module_type mty;
+
+    and iter_with_constraint cstr =
+      Iter.enter_with_constraint cstr;
+      begin
+        match cstr with
+          Twith_type decl -> iter_type_declaration decl
+        | Twith_module _ -> ()
+        | Twith_typesubst decl -> iter_type_declaration decl
+        | Twith_modsubst _ -> ()
+      end;
+      Iter.leave_with_constraint cstr;
+
+    and iter_module_expr mexpr =
+      Iter.enter_module_expr mexpr;
+      begin
+        match mexpr.mod_desc with
+          Tmod_ident (p, _) -> ()
+        | Tmod_structure st -> iter_structure st
+        | Tmod_functor (id, _, mtype, mexpr) ->
+            iter_module_type mtype;
+            iter_module_expr mexpr
+        | Tmod_apply (mexp1, mexp2, _) ->
+            iter_module_expr mexp1;
+            iter_module_expr mexp2
+        | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+            iter_module_expr mexpr
+        | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+            iter_module_expr mexpr;
+            iter_module_type mtype
+        | Tmod_unpack (exp, mty) ->
+            iter_expression exp
+(*          iter_module_type mty *)
+      end;
+      Iter.leave_module_expr mexpr;
+
+    and iter_class_expr cexpr =
+      Iter.enter_class_expr cexpr;
+      begin
+        match cexpr.cl_desc with
+        | Tcl_constraint (cl, None, _, _, _ ) ->
+            iter_class_expr cl;
+        | Tcl_structure clstr -> iter_class_structure clstr
+        | Tcl_fun (label, pat, priv, cl, partial) ->
+          iter_pattern pat;
+          List.iter (fun (id, _, exp) -> iter_expression exp) priv;
+          iter_class_expr cl
+
+        | Tcl_apply (cl, args) ->
+            iter_class_expr cl;
+            List.iter (fun (label, expo, _) ->
+                match expo with
+                  None -> ()
+                | Some exp -> iter_expression exp
+            ) args
+
+        | Tcl_let (rec_flat, bindings, ivars, cl) ->
+          iter_bindings rec_flat bindings;
+          List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
+            iter_class_expr cl
+
+        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+            iter_class_expr cl;
+            iter_class_type clty
+
+        | Tcl_ident (_, _, tyl) ->
+            List.iter iter_core_type tyl
+      end;
+      Iter.leave_class_expr cexpr;
+
+    and iter_class_type ct =
+      Iter.enter_class_type ct;
+      begin
+        match ct.cltyp_desc with
+          Tcty_signature csg -> iter_class_signature csg
+        | Tcty_constr (path, _, list) ->
+            List.iter iter_core_type list
+        | Tcty_fun (label, ct, cl) ->
+            iter_core_type ct;
+            iter_class_type cl
+      end;
+      Iter.leave_class_type ct;
+
+    and iter_class_signature cs =
+      Iter.enter_class_signature cs;
+      iter_core_type cs.csig_self;
+      List.iter iter_class_type_field cs.csig_fields;
+      Iter.leave_class_signature cs
+
+
+    and iter_class_type_field ctf =
+      Iter.enter_class_type_field ctf;
+      begin
+        match ctf.ctf_desc with
+          Tctf_inher ct -> iter_class_type ct
+        | Tctf_val (s, mut, virt, ct) ->
+            iter_core_type ct
+        | Tctf_virt  (s, priv, ct) ->
+            iter_core_type ct
+        | Tctf_meth  (s, priv, ct) ->
+            iter_core_type ct
+        | Tctf_cstr  (ct1, ct2) ->
+            iter_core_type ct1;
+            iter_core_type ct2
+      end;
+      Iter.leave_class_type_field ctf
+
+    and iter_core_type ct =
+      Iter.enter_core_type ct;
+      begin
+        match ct.ctyp_desc with
+          Ttyp_any -> ()
+        | Ttyp_var s -> ()
+        | Ttyp_arrow (label, ct1, ct2) ->
+            iter_core_type ct1;
+            iter_core_type ct2
+        | Ttyp_tuple list -> List.iter iter_core_type list
+        | Ttyp_constr (path, _, list) ->
+            List.iter iter_core_type list
+        | Ttyp_object list ->
+            List.iter iter_core_field_type list
+        | Ttyp_class (path, _, list, labels) ->
+            List.iter iter_core_type list
+        | Ttyp_alias (ct, s) ->
+            iter_core_type ct
+        | Ttyp_variant (list, bool, labels) ->
+            List.iter iter_row_field list
+        | Ttyp_poly (list, ct) -> iter_core_type ct
+        | Ttyp_package pack -> iter_package_type pack
+      end;
+      Iter.leave_core_type ct;
+
+    and iter_core_field_type cft =
+      Iter.enter_core_field_type cft;
+      begin match cft.field_desc with
+          Tcfield_var -> ()
+        | Tcfield (s, ct) -> iter_core_type ct
+      end;
+      Iter.leave_core_field_type cft;
+
+    and iter_class_structure cs =
+      Iter.enter_class_structure cs;
+      iter_pattern cs.cstr_pat;
+      List.iter iter_class_field cs.cstr_fields;
+      Iter.leave_class_structure cs;
+
+
+    and iter_row_field rf =
+      match rf with
+        Ttag (label, bool, list) ->
+          List.iter iter_core_type list
+      | Tinherit ct -> iter_core_type ct
+
+    and iter_class_field cf =
+      Iter.enter_class_field cf;
+      begin
+        match cf.cf_desc with
+          Tcf_inher (ovf, cl, super, _vals, _meths) ->
+          iter_class_expr cl
+      | Tcf_constr (cty, cty') ->
+          iter_core_type cty;
+          iter_core_type cty'
+      | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
+          iter_core_type cty
+      | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
+          iter_expression exp
+      | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
+          iter_core_type cty
+      | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
+          iter_expression exp
+(*      | Tcf_let (rec_flag, bindings, exps) ->
+          iter_bindings rec_flag bindings;
+        List.iter (fun (id, _, exp) -> iter_expression exp) exps; *)
+      | Tcf_init exp ->
+          iter_expression exp
+      end;
+      Iter.leave_class_field cf;
+
+  end
+
+module DefaultIteratorArgument = struct
+
+      let enter_structure _ = ()
+      let enter_value_description _ = ()
+      let enter_type_declaration _ = ()
+      let enter_exception_declaration _ = ()
+      let enter_pattern _ = ()
+      let enter_expression _ = ()
+      let enter_package_type _ = ()
+      let enter_signature _ = ()
+      let enter_signature_item _ = ()
+      let enter_modtype_declaration _ = ()
+      let enter_module_type _ = ()
+      let enter_module_expr _ = ()
+      let enter_with_constraint _ = ()
+      let enter_class_expr _ = ()
+      let enter_class_signature _ = ()
+      let enter_class_declaration _ = ()
+      let enter_class_description _ = ()
+      let enter_class_type_declaration _ = ()
+      let enter_class_type _ = ()
+      let enter_class_type_field _ = ()
+      let enter_core_type _ = ()
+      let enter_core_field_type _ = ()
+      let enter_class_structure _ = ()
+    let enter_class_field _ = ()
+    let enter_structure_item _ = ()
+
+
+      let leave_structure _ = ()
+      let leave_value_description _ = ()
+      let leave_type_declaration _ = ()
+      let leave_exception_declaration _ = ()
+      let leave_pattern _ = ()
+      let leave_expression _ = ()
+      let leave_package_type _ = ()
+      let leave_signature _ = ()
+      let leave_signature_item _ = ()
+      let leave_modtype_declaration _ = ()
+      let leave_module_type _ = ()
+      let leave_module_expr _ = ()
+      let leave_with_constraint _ = ()
+      let leave_class_expr _ = ()
+      let leave_class_signature _ = ()
+      let leave_class_declaration _ = ()
+      let leave_class_description _ = ()
+      let leave_class_type_declaration _ = ()
+      let leave_class_type _ = ()
+      let leave_class_type_field _ = ()
+      let leave_core_type _ = ()
+      let leave_core_field_type _ = ()
+      let leave_class_structure _ = ()
+    let leave_class_field _ = ()
+    let leave_structure_item _ = ()
+
+    let enter_binding _ _ = ()
+    let leave_binding _ _ = ()
+
+    let enter_bindings _ = ()
+    let leave_bindings _ = ()
+
+  end
diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli
new file mode 100644
index 00000000..be9c6eff
--- /dev/null
+++ b/typing/typedtreeIter.mli
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*    Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay)     *)
+(*                                                                        *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
+(*   en Automatique.  All rights reserved.  This file is distributed      *)
+(*   under the terms of the Q Public License version 1.0.                 *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Typedtree
+
+
+module type IteratorArgument = sig
+    val enter_structure : structure -> unit
+    val enter_value_description : value_description -> unit
+    val enter_type_declaration : type_declaration -> unit
+    val enter_exception_declaration :
+      exception_declaration -> unit
+    val enter_pattern : pattern -> unit
+    val enter_expression : expression -> unit
+    val enter_package_type : package_type -> unit
+    val enter_signature : signature -> unit
+    val enter_signature_item : signature_item -> unit
+    val enter_modtype_declaration : modtype_declaration -> unit
+    val enter_module_type : module_type -> unit
+    val enter_module_expr : module_expr -> unit
+    val enter_with_constraint : with_constraint -> unit
+    val enter_class_expr : class_expr -> unit
+    val enter_class_signature : class_signature -> unit
+    val enter_class_declaration : class_declaration -> unit
+    val enter_class_description : class_description -> unit
+    val enter_class_type_declaration : class_type_declaration -> unit
+    val enter_class_type : class_type -> unit
+    val enter_class_type_field : class_type_field -> unit
+    val enter_core_type : core_type -> unit
+    val enter_core_field_type : core_field_type -> unit
+    val enter_class_structure : class_structure -> unit
+    val enter_class_field : class_field -> unit
+    val enter_structure_item : structure_item -> unit
+
+
+      val leave_structure : structure -> unit
+    val leave_value_description : value_description -> unit
+    val leave_type_declaration : type_declaration -> unit
+    val leave_exception_declaration :
+      exception_declaration -> unit
+    val leave_pattern : pattern -> unit
+    val leave_expression : expression -> unit
+    val leave_package_type : package_type -> unit
+    val leave_signature : signature -> unit
+    val leave_signature_item : signature_item -> unit
+    val leave_modtype_declaration : modtype_declaration -> unit
+    val leave_module_type : module_type -> unit
+    val leave_module_expr : module_expr -> unit
+    val leave_with_constraint : with_constraint -> unit
+    val leave_class_expr : class_expr -> unit
+    val leave_class_signature : class_signature -> unit
+    val leave_class_declaration : class_declaration -> unit
+    val leave_class_description : class_description -> unit
+    val leave_class_type_declaration : class_type_declaration -> unit
+    val leave_class_type : class_type -> unit
+    val leave_class_type_field : class_type_field -> unit
+    val leave_core_type : core_type -> unit
+    val leave_core_field_type : core_field_type -> unit
+    val leave_class_structure : class_structure -> unit
+    val leave_class_field : class_field -> unit
+    val leave_structure_item : structure_item -> unit
+
+    val enter_bindings : rec_flag -> unit
+    val enter_binding : pattern -> expression -> unit
+    val leave_binding : pattern -> expression -> unit
+    val leave_bindings : rec_flag -> unit
+
+      end
+
+module MakeIterator :
+  functor
+  (Iter : IteratorArgument) ->
+           sig
+             val iter_structure : structure -> unit
+             val iter_signature : signature -> unit
+    val iter_structure_item : structure_item -> unit
+    val iter_signature_item : signature_item -> unit
+    val iter_expression : expression -> unit
+    val iter_module_type : module_type -> unit
+    val iter_pattern : pattern -> unit
+    val iter_class_expr : class_expr -> unit
+           end
+
+module DefaultIteratorArgument : IteratorArgument
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
new file mode 100644
index 00000000..7c8c633d
--- /dev/null
+++ b/typing/typedtreeMap.ml
@@ -0,0 +1,682 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Fabrice Le Fessant, INRIA Saclay                   *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+  val enter_structure : structure -> structure
+  val enter_value_description : value_description -> value_description
+  val enter_type_declaration : type_declaration -> type_declaration
+  val enter_exception_declaration :
+    exception_declaration -> exception_declaration
+  val enter_pattern : pattern -> pattern
+  val enter_expression : expression -> expression
+  val enter_package_type : package_type -> package_type
+  val enter_signature : signature -> signature
+  val enter_signature_item : signature_item -> signature_item
+  val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+  val enter_module_type : module_type -> module_type
+  val enter_module_expr : module_expr -> module_expr
+  val enter_with_constraint : with_constraint -> with_constraint
+  val enter_class_expr : class_expr -> class_expr
+  val enter_class_signature : class_signature -> class_signature
+  val enter_class_description : class_description -> class_description
+  val enter_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val enter_class_infos : 'a class_infos -> 'a class_infos
+  val enter_class_type : class_type -> class_type
+  val enter_class_type_field : class_type_field -> class_type_field
+  val enter_core_type : core_type -> core_type
+  val enter_core_field_type : core_field_type -> core_field_type
+  val enter_class_structure : class_structure -> class_structure
+  val enter_class_field : class_field -> class_field
+  val enter_structure_item : structure_item -> structure_item
+
+  val leave_structure : structure -> structure
+  val leave_value_description : value_description -> value_description
+  val leave_type_declaration : type_declaration -> type_declaration
+  val leave_exception_declaration :
+    exception_declaration -> exception_declaration
+  val leave_pattern : pattern -> pattern
+  val leave_expression : expression -> expression
+  val leave_package_type : package_type -> package_type
+  val leave_signature : signature -> signature
+  val leave_signature_item : signature_item -> signature_item
+  val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+  val leave_module_type : module_type -> module_type
+  val leave_module_expr : module_expr -> module_expr
+  val leave_with_constraint : with_constraint -> with_constraint
+  val leave_class_expr : class_expr -> class_expr
+  val leave_class_signature : class_signature -> class_signature
+  val leave_class_description : class_description -> class_description
+  val leave_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val leave_class_infos : 'a class_infos -> 'a class_infos
+  val leave_class_type : class_type -> class_type
+  val leave_class_type_field : class_type_field -> class_type_field
+  val leave_core_type : core_type -> core_type
+  val leave_core_field_type : core_field_type -> core_field_type
+  val leave_class_structure : class_structure -> class_structure
+  val leave_class_field : class_field -> class_field
+  val leave_structure_item : structure_item -> structure_item
+
+end
+
+
+module MakeMap(Map : MapArgument) = struct
+
+  let may_map f v =
+    match v with
+        None -> v
+      | Some x -> Some (f x)
+
+
+  open Misc
+  open Asttypes
+
+  let rec map_structure str =
+    let str = Map.enter_structure str in
+    let str_items = List.map map_structure_item str.str_items in
+    Map.leave_structure { str with str_items = str_items }
+
+  and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
+
+  and map_bindings rec_flag list =
+    List.map map_binding list
+
+  and map_structure_item item =
+    let item = Map.enter_structure_item item in
+    let str_desc =
+      match item.str_desc with
+          Tstr_eval exp -> Tstr_eval (map_expression exp)
+        | Tstr_value (rec_flag, list) ->
+          Tstr_value (rec_flag, map_bindings rec_flag list)
+        | Tstr_primitive (id, name, v) ->
+          Tstr_primitive (id, name, map_value_description v)
+        | Tstr_type list ->
+          Tstr_type (List.map (
+            fun (id, name, decl) ->
+              (id, name, map_type_declaration decl) ) list)
+        | Tstr_exception (id, name, decl) ->
+          Tstr_exception (id, name, map_exception_declaration decl)
+        | Tstr_exn_rebind (id, name, path, lid) ->
+          Tstr_exn_rebind (id, name, path, lid)
+        | Tstr_module (id, name, mexpr) ->
+          Tstr_module (id, name, map_module_expr mexpr)
+        | Tstr_recmodule list ->
+          let list =
+            List.map (fun (id, name, mtype, mexpr) ->
+              (id, name, map_module_type mtype, map_module_expr mexpr)
+            ) list
+          in
+          Tstr_recmodule list
+        | Tstr_modtype (id, name, mtype) ->
+          Tstr_modtype (id, name, map_module_type mtype)
+        | Tstr_open (ovf, path, lid) -> Tstr_open (ovf, path, lid)
+        | Tstr_class list ->
+          let list =
+            List.map (fun (ci, string_list, virtual_flag) ->
+              let ci = Map.enter_class_infos ci in
+              let ci_expr = map_class_expr ci.ci_expr in
+              (Map.leave_class_infos { ci with ci_expr = ci_expr},
+               string_list, virtual_flag)
+            ) list
+          in
+          Tstr_class list
+        | Tstr_class_type list ->
+          let list = List.map (fun (id, name, ct) ->
+            let ct = Map.enter_class_infos ct in
+            let ci_expr = map_class_type ct.ci_expr in
+            (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
+          ) list in
+          Tstr_class_type list
+        | Tstr_include (mexpr, sg) ->
+          Tstr_include (map_module_expr mexpr, sg)
+    in
+    Map.leave_structure_item { item with str_desc = str_desc}
+
+  and map_value_description v =
+    let v = Map.enter_value_description v in
+    let val_desc = map_core_type v.val_desc in
+    Map.leave_value_description { v with val_desc = val_desc }
+
+  and map_type_declaration decl =
+    let decl = Map.enter_type_declaration decl in
+    let typ_cstrs = List.map (fun (ct1, ct2, loc) ->
+      (map_core_type ct1,
+       map_core_type ct2,
+       loc)
+    ) decl.typ_cstrs in
+    let typ_kind = match decl.typ_kind with
+        Ttype_abstract -> Ttype_abstract
+      | Ttype_variant list ->
+        let list = List.map (fun (s, name, cts, loc) ->
+          (s, name, List.map map_core_type cts, loc)
+        ) list in
+        Ttype_variant list
+      | Ttype_record list ->
+        let list =
+          List.map (fun (s, name, mut, ct, loc) ->
+            (s, name, mut, map_core_type ct, loc)
+          ) list in
+        Ttype_record list
+    in
+    let typ_manifest =
+      match decl.typ_manifest with
+          None -> None
+        | Some ct -> Some (map_core_type ct)
+    in
+    Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs;
+      typ_kind = typ_kind; typ_manifest = typ_manifest }
+
+  and map_exception_declaration decl =
+    let decl = Map.enter_exception_declaration decl in
+    let exn_params = List.map map_core_type decl.exn_params in
+    let decl =       { exn_params = exn_params;
+                       exn_exn = decl.exn_exn;
+                       exn_loc = decl.exn_loc } in
+    Map.leave_exception_declaration decl;
+
+  and map_pattern pat =
+    let pat = Map.enter_pattern pat in
+    let pat_desc =
+      match pat.pat_desc with
+        | Tpat_alias (pat1, p, text) ->
+          let pat1 = map_pattern pat1 in
+          Tpat_alias (pat1, p, text)
+        | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
+        | Tpat_construct (lid, cstr_decl, args, arity) ->
+          Tpat_construct (lid, cstr_decl,
+                          List.map map_pattern args, arity)
+        | Tpat_variant (label, pato, rowo) ->
+          let pato = match pato with
+              None -> pato
+            | Some pat -> Some (map_pattern pat)
+          in
+          Tpat_variant (label, pato, rowo)
+        | Tpat_record (list, closed) ->
+          Tpat_record (List.map (fun (lid, lab_desc, pat) ->
+            (lid, lab_desc, map_pattern pat) ) list, closed)
+        | Tpat_array list -> Tpat_array (List.map map_pattern list)
+        | Tpat_or (p1, p2, rowo) ->
+          Tpat_or (map_pattern p1, map_pattern p2, rowo)
+        | Tpat_lazy p -> Tpat_lazy (map_pattern p)
+        | Tpat_constant _
+        | Tpat_any
+        | Tpat_var _ -> pat.pat_desc
+
+    in
+    let pat_extra = List.map map_pat_extra pat.pat_extra in
+    Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra }
+
+  and map_pat_extra pat_extra =
+    match pat_extra with
+      | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type  ct), loc)
+      | (Tpat_type _ | Tpat_unpack), _ -> pat_extra
+
+  and map_expression exp =
+    let exp = Map.enter_expression exp in
+    let exp_desc =
+      match exp.exp_desc with
+          Texp_ident (_, _, _)
+        | Texp_constant _ -> exp.exp_desc
+        | Texp_let (rec_flag, list, exp) ->
+          Texp_let (rec_flag,
+                    map_bindings rec_flag list,
+                    map_expression exp)
+        | Texp_function (label, cases, partial) ->
+          Texp_function (label, map_bindings Nonrecursive cases, partial)
+        | Texp_apply (exp, list) ->
+          Texp_apply (map_expression exp,
+                      List.map (fun (label, expo, optional) ->
+                        let expo =
+                          match expo with
+                              None -> expo
+                            | Some exp -> Some (map_expression exp)
+                        in
+                        (label, expo, optional)
+                      ) list )
+        | Texp_match (exp, list, partial) ->
+          Texp_match (
+            map_expression exp,
+            map_bindings Nonrecursive list,
+            partial
+          )
+        | Texp_try (exp, list) ->
+          Texp_try (
+            map_expression exp,
+            map_bindings Nonrecursive list
+          )
+        | Texp_tuple list ->
+          Texp_tuple (List.map map_expression list)
+        | Texp_construct (lid, cstr_desc, args, arity) ->
+          Texp_construct (lid, cstr_desc,
+                          List.map map_expression args, arity )
+        | Texp_variant (label, expo) ->
+          let expo =match expo with
+              None -> expo
+            | Some exp -> Some (map_expression exp)
+          in
+          Texp_variant (label, expo)
+        | Texp_record (list, expo) ->
+          let list =
+            List.map (fun (lid, lab_desc, exp) ->
+              (lid, lab_desc, map_expression exp)
+            ) list in
+          let expo = match expo with
+              None -> expo
+            | Some exp -> Some (map_expression exp)
+          in
+          Texp_record (list, expo)
+        | Texp_field (exp, lid, label) ->
+          Texp_field (map_expression exp, lid, label)
+        | Texp_setfield (exp1, lid, label, exp2) ->
+          Texp_setfield (
+            map_expression exp1,
+            lid,
+            label,
+            map_expression exp2)
+        | Texp_array list ->
+          Texp_array (List.map map_expression list)
+        | Texp_ifthenelse (exp1, exp2, expo) ->
+          Texp_ifthenelse (
+            map_expression exp1,
+            map_expression exp2,
+            match expo with
+                None -> expo
+              | Some exp -> Some (map_expression exp)
+          )
+        | Texp_sequence (exp1, exp2) ->
+          Texp_sequence (
+            map_expression exp1,
+            map_expression exp2
+          )
+        | Texp_while (exp1, exp2) ->
+          Texp_while (
+            map_expression exp1,
+            map_expression exp2
+          )
+        | Texp_for (id, name, exp1, exp2, dir, exp3) ->
+          Texp_for (
+            id, name,
+            map_expression exp1,
+            map_expression exp2,
+            dir,
+            map_expression exp3
+          )
+        | Texp_when (exp1, exp2) ->
+          Texp_when (
+            map_expression exp1,
+            map_expression exp2
+          )
+        | Texp_send (exp, meth, expo) ->
+          Texp_send (map_expression exp, meth, may_map map_expression expo)
+        | Texp_new (path, lid, cl_decl) -> exp.exp_desc
+        | Texp_instvar (_, path, _) -> exp.exp_desc
+        | Texp_setinstvar (path, lid, path2, exp) ->
+          Texp_setinstvar (path, lid, path2, map_expression exp)
+        | Texp_override (path, list) ->
+          Texp_override (
+            path,
+            List.map (fun (path, lid, exp) ->
+              (path, lid, map_expression exp)
+            ) list
+          )
+        | Texp_letmodule (id, name, mexpr, exp) ->
+          Texp_letmodule (
+            id, name,
+            map_module_expr mexpr,
+            map_expression exp
+          )
+        | Texp_assert exp -> Texp_assert (map_expression exp)
+        | Texp_assertfalse -> exp.exp_desc
+        | Texp_lazy exp -> Texp_lazy (map_expression exp)
+        | Texp_object (cl, string_list) ->
+          Texp_object (map_class_structure cl, string_list)
+        | Texp_pack (mexpr) ->
+          Texp_pack (map_module_expr mexpr)
+    in
+    let exp_extra = List.map map_exp_extra exp.exp_extra in
+    Map.leave_expression {
+      exp with
+        exp_desc = exp_desc;
+        exp_extra = exp_extra }
+
+  and map_exp_extra exp_extra =
+    let loc = snd exp_extra in
+    match fst exp_extra with
+      | Texp_constraint (Some ct, None) ->
+        Texp_constraint (Some (map_core_type ct), None), loc
+      | Texp_constraint (None, Some ct) ->
+        Texp_constraint (None, Some (map_core_type ct)), loc
+      | Texp_constraint (Some ct1, Some ct2) ->
+        Texp_constraint (Some (map_core_type ct1),
+                         Some (map_core_type ct2)), loc
+      | Texp_poly (Some ct) ->
+        Texp_poly (Some ( map_core_type ct )), loc
+      | Texp_newtype _
+      | Texp_constraint (None, None)
+      | Texp_open _
+      | Texp_poly None -> exp_extra
+
+
+  and map_package_type pack =
+    let pack = Map.enter_package_type pack in
+    let pack_fields = List.map (
+      fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in
+    Map.leave_package_type { pack with pack_fields = pack_fields }
+
+  and map_signature sg =
+    let sg = Map.enter_signature sg in
+    let sig_items = List.map map_signature_item sg.sig_items in
+    Map.leave_signature { sg with sig_items = sig_items }
+
+  and map_signature_item item =
+    let item = Map.enter_signature_item item in
+    let sig_desc =
+      match item.sig_desc with
+          Tsig_value (id, name, v) ->
+            Tsig_value (id, name, map_value_description v)
+        | Tsig_type list -> Tsig_type (
+          List.map (fun (id, name, decl) ->
+            (id, name, map_type_declaration decl)
+          ) list
+        )
+        | Tsig_exception (id, name, decl) ->
+          Tsig_exception (id, name, map_exception_declaration decl)
+        | Tsig_module (id, name, mtype) ->
+          Tsig_module (id, name, map_module_type mtype)
+        | Tsig_recmodule list ->
+          Tsig_recmodule (List.map (
+            fun (id, name, mtype) ->
+              (id, name, map_module_type mtype) ) list)
+        | Tsig_modtype (id, name, mdecl) ->
+          Tsig_modtype (id, name, map_modtype_declaration mdecl)
+        | Tsig_open _ -> item.sig_desc
+        | Tsig_include (mty, sg) -> Tsig_include (map_module_type mty, sg)
+        | Tsig_class list -> Tsig_class (List.map map_class_description list)
+        | Tsig_class_type list ->
+          Tsig_class_type (List.map map_class_type_declaration list)
+    in
+    Map.leave_signature_item { item with sig_desc = sig_desc }
+
+  and map_modtype_declaration mdecl =
+    let mdecl = Map.enter_modtype_declaration mdecl in
+    let mdecl =
+      match mdecl with
+          Tmodtype_abstract -> Tmodtype_abstract
+        | Tmodtype_manifest mtype ->
+          Tmodtype_manifest (map_module_type mtype)
+    in
+    Map.leave_modtype_declaration mdecl
+
+
+  and map_class_description cd =
+    let cd = Map.enter_class_description cd in
+    let ci_expr = map_class_type cd.ci_expr in
+    Map.leave_class_description { cd with ci_expr = ci_expr}
+
+  and map_class_type_declaration cd =
+    let cd = Map.enter_class_type_declaration cd in
+    let ci_expr = map_class_type cd.ci_expr in
+    Map.leave_class_type_declaration { cd with ci_expr = ci_expr }
+
+  and map_module_type mty =
+    let mty = Map.enter_module_type mty in
+    let mty_desc =
+      match mty.mty_desc with
+          Tmty_ident (path, lid) -> mty.mty_desc
+        | Tmty_signature sg -> Tmty_signature (map_signature sg)
+        | Tmty_functor (id, name, mtype1, mtype2) ->
+          Tmty_functor (id, name, map_module_type mtype1,
+                        map_module_type mtype2)
+        | Tmty_with (mtype, list) ->
+          Tmty_with (map_module_type mtype,
+                     List.map (fun (path, lid, withc) ->
+                       (path, lid, map_with_constraint withc)
+                     ) list)
+        | Tmty_typeof mexpr ->
+          Tmty_typeof (map_module_expr mexpr)
+    in
+    Map.leave_module_type { mty with mty_desc = mty_desc}
+
+  and map_with_constraint cstr =
+    let cstr = Map.enter_with_constraint cstr in
+    let cstr =
+      match cstr with
+          Twith_type decl -> Twith_type (map_type_declaration decl)
+        | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
+        | Twith_module (path, lid) -> cstr
+        | Twith_modsubst (path, lid) -> cstr
+    in
+    Map.leave_with_constraint cstr
+
+  and map_module_expr mexpr =
+    let mexpr = Map.enter_module_expr mexpr in
+    let mod_desc =
+      match mexpr.mod_desc with
+          Tmod_ident (p, lid) -> mexpr.mod_desc
+        | Tmod_structure st -> Tmod_structure (map_structure st)
+        | Tmod_functor (id, name, mtype, mexpr) ->
+          Tmod_functor (id, name, map_module_type mtype,
+                        map_module_expr mexpr)
+        | Tmod_apply (mexp1, mexp2, coercion) ->
+          Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion)
+        | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) ->
+          Tmod_constraint (map_module_expr mexpr, mod_type,
+                           Tmodtype_implicit, coercion)
+        | Tmod_constraint (mexpr, mod_type,
+                           Tmodtype_explicit mtype, coercion) ->
+          Tmod_constraint (map_module_expr mexpr, mod_type,
+                           Tmodtype_explicit (map_module_type mtype),
+                           coercion)
+        | Tmod_unpack (exp, mod_type) ->
+          Tmod_unpack (map_expression exp, mod_type)
+    in
+    Map.leave_module_expr { mexpr with mod_desc = mod_desc }
+
+  and map_class_expr cexpr =
+    let cexpr = Map.enter_class_expr cexpr in
+    let cl_desc =
+      match cexpr.cl_desc with
+        | Tcl_constraint (cl, None, string_list1, string_list2, concr ) ->
+          Tcl_constraint (map_class_expr cl, None, string_list1,
+                          string_list2, concr)
+        | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr)
+        | Tcl_fun (label, pat, priv, cl, partial) ->
+          Tcl_fun (label, map_pattern pat,
+                   List.map (fun (id, name, exp) ->
+                     (id, name, map_expression exp)) priv,
+                   map_class_expr cl, partial)
+
+        | Tcl_apply (cl, args) ->
+          Tcl_apply (map_class_expr cl,
+                     List.map (fun (label, expo, optional) ->
+                       (label, may_map map_expression expo,
+                        optional)
+                     ) args)
+        | Tcl_let (rec_flat, bindings, ivars, cl) ->
+          Tcl_let (rec_flat, map_bindings rec_flat bindings,
+                   List.map (fun (id, name, exp) ->
+                     (id, name, map_expression exp)) ivars,
+                   map_class_expr cl)
+
+        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+          Tcl_constraint ( map_class_expr cl,
+                           Some (map_class_type clty), vals, meths, concrs)
+
+        | Tcl_ident (id, name, tyl) ->
+          Tcl_ident (id, name, List.map map_core_type tyl)
+    in
+    Map.leave_class_expr { cexpr with cl_desc = cl_desc }
+
+  and map_class_type ct =
+    let ct = Map.enter_class_type ct in
+    let cltyp_desc =
+      match ct.cltyp_desc with
+          Tcty_signature csg -> Tcty_signature (map_class_signature csg)
+        | Tcty_constr (path, lid, list) ->
+          Tcty_constr (path, lid, List.map map_core_type list)
+        | Tcty_fun (label, ct, cl) ->
+          Tcty_fun (label, map_core_type ct, map_class_type cl)
+    in
+    Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
+
+  and map_class_signature cs =
+    let cs = Map.enter_class_signature cs in
+    let csig_self = map_core_type cs.csig_self in
+    let csig_fields = List.map map_class_type_field cs.csig_fields in
+    Map.leave_class_signature { cs with
+      csig_self = csig_self; csig_fields = csig_fields }
+
+
+  and map_class_type_field ctf =
+    let ctf = Map.enter_class_type_field ctf in
+    let ctf_desc =
+      match ctf.ctf_desc with
+          Tctf_inher ct -> Tctf_inher (map_class_type ct)
+        | Tctf_val (s, mut, virt, ct) ->
+          Tctf_val (s, mut, virt, map_core_type ct)
+        | Tctf_virt  (s, priv, ct) ->
+          Tctf_virt (s, priv, map_core_type ct)
+        | Tctf_meth  (s, priv, ct) ->
+          Tctf_meth (s, priv, map_core_type ct)
+        | Tctf_cstr  (ct1, ct2) ->
+          Tctf_cstr (map_core_type ct1, map_core_type ct2)
+    in
+    Map.leave_class_type_field { ctf with ctf_desc = ctf_desc }
+
+  and map_core_type ct =
+    let ct = Map.enter_core_type ct in
+    let ctyp_desc =
+      match ct.ctyp_desc with
+          Ttyp_any
+        | Ttyp_var _ -> ct.ctyp_desc
+        | Ttyp_arrow (label, ct1, ct2) ->
+          Ttyp_arrow (label, map_core_type ct1, map_core_type ct2)
+        | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list)
+        | Ttyp_constr (path, lid, list) ->
+          Ttyp_constr (path, lid, List.map map_core_type list)
+        | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list)
+        | Ttyp_class (path, lid, list, labels) ->
+          Ttyp_class (path, lid, List.map map_core_type list, labels)
+        | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
+        | Ttyp_variant (list, bool, labels) ->
+          Ttyp_variant (List.map map_row_field list, bool, labels)
+        | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct)
+        | Ttyp_package pack -> Ttyp_package (map_package_type pack)
+    in
+    Map.leave_core_type { ct with ctyp_desc = ctyp_desc }
+
+  and map_core_field_type cft =
+    let cft = Map.enter_core_field_type cft in
+    let field_desc = match cft.field_desc with
+        Tcfield_var -> Tcfield_var
+      | Tcfield (s, ct) -> Tcfield (s, map_core_type ct)
+    in
+    Map.leave_core_field_type { cft with field_desc = field_desc }
+
+  and map_class_structure cs =
+    let cs = Map.enter_class_structure cs in
+    let cstr_pat = map_pattern cs.cstr_pat in
+    let cstr_fields = List.map map_class_field cs.cstr_fields in
+    Map.leave_class_structure { cs with cstr_pat = cstr_pat;
+      cstr_fields = cstr_fields }
+
+  and map_row_field rf =
+    match rf with
+        Ttag (label, bool, list) ->
+          Ttag (label, bool, List.map map_core_type list)
+      | Tinherit ct -> Tinherit (map_core_type ct)
+
+  and map_class_field cf =
+    let cf = Map.enter_class_field cf in
+    let cf_desc =
+      match cf.cf_desc with
+          Tcf_inher (ovf, cl, super, vals, meths) ->
+            Tcf_inher (ovf, map_class_expr cl, super, vals, meths)
+        | Tcf_constr (cty, cty') ->
+          Tcf_constr (map_core_type cty, map_core_type cty')
+        | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) ->
+          Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty),
+                   override)
+        | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) ->
+          Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp),
+                   override)
+        | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) ->
+          Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty),
+                    override)
+        | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) ->
+          Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp),
+                    override)
+        | Tcf_init exp -> Tcf_init (map_expression exp)
+    in
+    Map.leave_class_field { cf with cf_desc = cf_desc }
+end
+
+
+module DefaultMapArgument = struct
+
+  let enter_structure t = t
+  let enter_value_description t = t
+  let enter_type_declaration t = t
+  let enter_exception_declaration t = t
+  let enter_pattern t = t
+  let enter_expression t = t
+  let enter_package_type t = t
+  let enter_signature t = t
+  let enter_signature_item t = t
+  let enter_modtype_declaration t = t
+  let enter_module_type t = t
+  let enter_module_expr t = t
+  let enter_with_constraint t = t
+  let enter_class_expr t = t
+  let enter_class_signature t = t
+  let enter_class_description t = t
+  let enter_class_type_declaration t = t
+  let enter_class_infos t = t
+  let enter_class_type t = t
+  let enter_class_type_field t = t
+  let enter_core_type t = t
+  let enter_core_field_type t = t
+  let enter_class_structure t = t
+  let enter_class_field t = t
+  let enter_structure_item t = t
+
+
+  let leave_structure t = t
+  let leave_value_description t = t
+  let leave_type_declaration t = t
+  let leave_exception_declaration t = t
+  let leave_pattern t = t
+  let leave_expression t = t
+  let leave_package_type t = t
+  let leave_signature t = t
+  let leave_signature_item t = t
+  let leave_modtype_declaration t = t
+  let leave_module_type t = t
+  let leave_module_expr t = t
+  let leave_with_constraint t = t
+  let leave_class_expr t = t
+  let leave_class_signature t = t
+  let leave_class_description t = t
+  let leave_class_type_declaration t = t
+  let leave_class_infos t = t
+  let leave_class_type t = t
+  let leave_class_type_field t = t
+  let leave_core_type t = t
+  let leave_core_field_type t = t
+  let leave_class_structure t = t
+  let leave_class_field t = t
+  let leave_structure_item t = t
+
+end
diff --git a/typing/typedtreeMap.mli b/typing/typedtreeMap.mli
new file mode 100644
index 00000000..0248f023
--- /dev/null
+++ b/typing/typedtreeMap.mli
@@ -0,0 +1,89 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                  Fabrice Le Fessant, INRIA Saclay                   *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Typedtree
+
+module type MapArgument = sig
+  val enter_structure : structure -> structure
+  val enter_value_description : value_description -> value_description
+  val enter_type_declaration : type_declaration -> type_declaration
+  val enter_exception_declaration :
+    exception_declaration -> exception_declaration
+  val enter_pattern : pattern -> pattern
+  val enter_expression : expression -> expression
+  val enter_package_type : package_type -> package_type
+  val enter_signature : signature -> signature
+  val enter_signature_item : signature_item -> signature_item
+  val enter_modtype_declaration : modtype_declaration -> modtype_declaration
+  val enter_module_type : module_type -> module_type
+  val enter_module_expr : module_expr -> module_expr
+  val enter_with_constraint : with_constraint -> with_constraint
+  val enter_class_expr : class_expr -> class_expr
+  val enter_class_signature : class_signature -> class_signature
+  val enter_class_description : class_description -> class_description
+  val enter_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val enter_class_infos : 'a class_infos -> 'a class_infos
+  val enter_class_type : class_type -> class_type
+  val enter_class_type_field : class_type_field -> class_type_field
+  val enter_core_type : core_type -> core_type
+  val enter_core_field_type : core_field_type -> core_field_type
+  val enter_class_structure : class_structure -> class_structure
+  val enter_class_field : class_field -> class_field
+  val enter_structure_item : structure_item -> structure_item
+
+  val leave_structure : structure -> structure
+  val leave_value_description : value_description -> value_description
+  val leave_type_declaration : type_declaration -> type_declaration
+  val leave_exception_declaration :
+    exception_declaration -> exception_declaration
+  val leave_pattern : pattern -> pattern
+  val leave_expression : expression -> expression
+  val leave_package_type : package_type -> package_type
+  val leave_signature : signature -> signature
+  val leave_signature_item : signature_item -> signature_item
+  val leave_modtype_declaration : modtype_declaration -> modtype_declaration
+  val leave_module_type : module_type -> module_type
+  val leave_module_expr : module_expr -> module_expr
+  val leave_with_constraint : with_constraint -> with_constraint
+  val leave_class_expr : class_expr -> class_expr
+  val leave_class_signature : class_signature -> class_signature
+  val leave_class_description : class_description -> class_description
+  val leave_class_type_declaration :
+    class_type_declaration -> class_type_declaration
+  val leave_class_infos : 'a class_infos -> 'a class_infos
+  val leave_class_type : class_type -> class_type
+  val leave_class_type_field : class_type_field -> class_type_field
+  val leave_core_type : core_type -> core_type
+  val leave_core_field_type : core_field_type -> core_field_type
+  val leave_class_structure : class_structure -> class_structure
+  val leave_class_field : class_field -> class_field
+  val leave_structure_item : structure_item -> structure_item
+
+end
+
+module MakeMap :
+  functor
+    (Iter : MapArgument) ->
+sig
+  val map_structure : structure -> structure
+  val map_pattern : pattern -> pattern
+  val map_structure_item : structure_item -> structure_item
+  val map_expression : expression -> expression
+  val map_class_expr : class_expr -> class_expr
+
+  val map_signature : signature -> signature
+  val map_signature_item : signature_item -> signature_item
+  val map_module_type : module_type -> module_type
+end
+
+module DefaultMapArgument : MapArgument
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 5643968d..7cbda254 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typemod.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 open Misc
 open Longident
 open Path
@@ -40,7 +38,7 @@ type error =
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
 open Typedtree
 
@@ -57,19 +55,19 @@ let rec path_concat head p =
 let extract_sig env loc mty =
   match Mtype.scrape env mty with
     Mty_signature sg -> sg
-  | _ -> raise(Error(loc, Signature_expected))
+  | _ -> raise(Error(loc, env, Signature_expected))
 
 let extract_sig_open env loc mty =
   match Mtype.scrape env mty with
     Mty_signature sg -> sg
-  | _ -> raise(Error(loc, Structure_expected mty))
+  | _ -> raise(Error(loc, env, Structure_expected mty))
 
 (* Compute the environment after opening a module *)
 
-let type_open ?toplevel env loc lid =
+let type_open ?toplevel ovf env loc lid =
   let (path, mty) = Typetexp.find_module env loc lid.txt in
   let sg = extract_sig_open env loc mty in
-  path, Env.open_signature ~loc ?toplevel path sg env
+  path, Env.open_signature ~loc ?toplevel ovf path sg env
 
 (* Record a module type *)
 let rm node =
@@ -89,12 +87,13 @@ let rec add_rec_types env = function
       add_rec_types (Env.add_type id decl env) rem
   | _ -> env
 
-let check_type_decl env id row_id newdecl decl rs rem =
+let check_type_decl env loc id row_id newdecl decl rs rem =
   let env = Env.add_type id newdecl env in
   let env =
     match row_id with None -> env | Some id -> Env.add_type 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 env id newdecl decl;
+  Typedecl.check_coherence env loc id newdecl
 
 let rec make_params n = function
     [] -> []
@@ -116,12 +115,16 @@ let sig_item desc typ env loc = {
   Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env
 }
 
+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 merge_constraint initial_env loc  sg lid constr =
   let real_id = ref None in
   let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
       ([], _, _) ->
-        raise(Error(loc, With_no_component lid.txt))
+        raise(Error(loc, env, With_no_component lid.txt))
     | (Sig_type(id, decl, rs) :: rem, [s],
        Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
       when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
@@ -133,16 +136,16 @@ let merge_constraint initial_env loc  sg lid constr =
             type_private = Private;
             type_manifest = None;
             type_variance =
-              List.map (fun (c,n) -> (not n, not c, not c))
+              List.map (fun (c,n) -> make (not n) (not c) false)
               sdecl.ptype_variance;
-            type_loc = Location.none;
+            type_loc = sdecl.ptype_loc;
             type_newtype_level = None }
         and id_row = Ident.create (s^"#row") in
         let initial_env = Env.add_type id_row decl_row initial_env in
         let tdecl = Typedecl.transl_with_constraint
                         initial_env id (Some(Pident id_row)) decl sdecl in
         let newdecl = tdecl.typ_type in
-        check_type_decl env id row_id newdecl decl rs rem;
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
         let decl_row = {decl_row with type_params = newdecl.type_params} in
         let rs' = if rs = Trec_first then Trec_not else rs in
         (Pident id, lid, Twith_type tdecl),
@@ -152,7 +155,7 @@ let merge_constraint initial_env loc  sg lid constr =
         let tdecl =
           Typedecl.transl_with_constraint initial_env id None decl sdecl in
         let newdecl = tdecl.typ_type in
-        check_type_decl env id row_id newdecl decl rs rem;
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
         (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
     | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
       when Ident.name id = s ^ "#row" ->
@@ -163,7 +166,7 @@ let merge_constraint initial_env loc  sg lid constr =
         let tdecl =
           Typedecl.transl_with_constraint initial_env id None decl sdecl in
         let newdecl = tdecl.typ_type in
-        check_type_decl env id row_id newdecl decl rs rem;
+        check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
         real_id := Some id;
         (Pident id, lid, Twith_typesubst tdecl),
         make_next_first rs rem
@@ -216,7 +219,8 @@ let merge_constraint initial_env loc  sg lid constr =
               ) params sdecl.ptype_params;
               lid
           | _ -> raise Exit
-          with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
+          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
@@ -234,7 +238,7 @@ let merge_constraint initial_env loc  sg lid constr =
     in
     (tcstr, sg)
   with Includemod.Error explanation ->
-    raise(Error(loc, With_mismatch(lid.txt, explanation)))
+    raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation)))
 
 (* Add recursion flags on declarations arising from a mutually recursive
    block. *)
@@ -244,11 +248,14 @@ let map_rec fn decls rem =
   | [] -> rem
   | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
 
+let map_rec' = map_rec
+(*
 let rec map_rec' fn decls rem =
   match decls with
   | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
       fn Trec_not d1 :: map_rec' fn dl rem
   | _ -> map_rec fn decls rem
+*)
 
 let rec map_rec'' fn decls rem =
   match decls with
@@ -308,8 +315,8 @@ and approx_sig env ssg =
           let info = approx_modtype_info env sinfo in
           let (id, newenv) = Env.enter_modtype name.txt info env in
           Sig_modtype(id, info) :: approx_sig newenv srem
-      | Psig_open lid ->
-          let (path, mty) = type_open env item.psig_loc lid in
+      | Psig_open (ovf, lid) ->
+          let (path, mty) = type_open ovf env item.psig_loc lid in
           approx_sig mty srem
       | Psig_include smty ->
           let mty = approx_modtype env smty in
@@ -354,11 +361,12 @@ let check_recmod_typedecls env sdecls decls =
 
 (* Auxiliaries for checking uniqueness of names in signatures and structures *)
 
-module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringSet =
+  Set.Make(struct type t = string let compare (x:t) y = compare x y end)
 
 let check cl loc set_ref name =
   if StringSet.mem name !set_ref
-  then raise(Error(loc, Repeated_name(cl, name)))
+  then raise(Error(loc, Env.empty, Repeated_name(cl, name)))
   else set_ref := StringSet.add name !set_ref
 
 let check_sig_item type_names module_names modtype_names loc = function
@@ -370,17 +378,27 @@ let check_sig_item type_names module_names modtype_names loc = function
       check "module type" loc modtype_names (Ident.name id)
   | _ -> ()
 
-let rec remove_values ids = function
+let rec remove_duplicates val_ids exn_ids  = function
     [] -> []
   | Sig_value (id, _) :: rem
-    when List.exists (Ident.equal id) ids -> remove_values ids rem
-  | f :: rem -> f :: remove_values ids rem
+    when List.exists (Ident.equal id) val_ids ->
+      remove_duplicates val_ids exn_ids rem
+  | Sig_exception(id, _) :: rem
+    when List.exists (Ident.equal id) exn_ids ->
+      remove_duplicates val_ids exn_ids rem
+  | f :: rem -> f :: remove_duplicates val_ids exn_ids rem
 
 let rec get_values = function
     [] -> []
   | Sig_value (id, _) :: rem -> id :: get_values rem
   | f :: rem -> get_values rem
 
+let rec get_exceptions = function
+    [] -> []
+  | Sig_exception (id, _) :: rem -> id :: get_exceptions rem
+  | f :: rem -> get_exceptions rem
+
+
 (* Check and translate a module type expression *)
 
 let transl_modtype_longident loc env lid =
@@ -475,7 +493,8 @@ and transl_signature env sg =
             let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_exception (id, name, arg)) env loc :: trem,
-            Sig_exception(id, arg.exn_exn) :: rem,
+            (if List.exists (Ident.equal id) (get_exceptions rem) then rem
+            else Sig_exception(id, arg.exn_exn) :: rem),
             final_env
         | Psig_module(name, smty) ->
             check "module" item.psig_loc module_names name.txt;
@@ -506,10 +525,11 @@ and transl_signature env sg =
             mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem,
             Sig_modtype(id, info) :: rem,
             final_env
-        | Psig_open lid ->
-            let (path, newenv) = type_open env item.psig_loc lid in
+        | Psig_open (ovf, lid) ->
+            let (path, newenv) = type_open ovf env item.psig_loc lid in
             let (trem, rem, final_env) = transl_sig newenv srem in
-            mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env
+            mksig (Tsig_open (ovf, path,lid)) env loc :: trem,
+            rem, final_env
         | Psig_include smty ->
             let tmty = transl_modtype env smty in
             let mty = tmty.mty_type in
@@ -522,7 +542,8 @@ and transl_signature env sg =
             let newenv = Env.add_signature sg env in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_include (tmty, sg)) env loc :: trem,
-            remove_values (get_values rem) sg @ rem, final_env
+            remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem,
+            final_env
         | Psig_class cl ->
             List.iter
               (fun {pci_name = name} ->
@@ -594,11 +615,27 @@ and transl_recmodule_modtypes loc env sdecls =
     List.map2
       (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
       sdecls curr in
+  let ids = List.map (fun (name, _) -> Ident.create name.txt) sdecls in
+  let approx_env =
+    (*
+       cf #5965
+       We use a dummy module type in order to detect a reference to one
+       of the module being defined during the call to approx_modtype.
+       It will be detected in Env.lookup_module.
+    *)
+    List.fold_left
+      (fun env id ->
+         let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in
+         Env.add_module id dummy env
+      )
+      env ids
+  in
   let init =
-    List.map
-      (fun (name, smty) ->
-        (Ident.create name.txt, name, approx_modtype env smty))
-      sdecls in
+    List.map2
+      (fun id (name, smty) ->
+         (id, name, approx_modtype approx_env smty))
+      ids sdecls
+  in
   let env0 = make_env init in
   let dcl1 = transition env0 init in
   let env1 = make_env2 dcl1 in
@@ -643,30 +680,16 @@ let check_nongen_scheme env str =
       List.iter
         (fun (pat, exp) ->
           if not (Ctype.closed_schema exp.exp_type) then
-            raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
+            raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type)))
         pat_exp_list
   | Tstr_module(id, _, md) ->
       if not (closed_modtype md.mod_type) then
-        raise(Error(md.mod_loc, Non_generalizable_module md.mod_type))
+        raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type))
   | _ -> ()
 
 let check_nongen_schemes env str =
   List.iter (check_nongen_scheme env) str
 
-(* Extract the list of "value" identifiers bound by a signature.
-   "Value" identifiers are identifiers for signature components that
-   correspond to a run-time value: values, exceptions, modules, classes.
-   Note: manifest primitives do not correspond to a run-time value! *)
-
-let rec bound_value_identifiers = function
-    [] -> []
-  | Sig_value(id, {val_kind = Val_reg}) :: rem ->
-      id :: bound_value_identifiers rem
-  | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
-  | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
-  | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
-  | _ :: rem -> bound_value_identifiers rem
-
 (* Helpers for typing recursive modules *)
 
 let anchor_submodule name anchor =
@@ -754,7 +777,7 @@ let check_recmodule_inclusion env bindings =
           try
             Includemod.modtypes env mty_actual' mty_decl'
           with Includemod.Error msg ->
-            raise(Error(modl.mod_loc, Not_included msg)) in
+            raise(Error(modl.mod_loc, env, Not_included msg)) in
         let modl' =
             { mod_desc = Tmod_constraint(modl, mty_decl.mty_type,
                 Tmodtype_explicit mty_decl, coercion);
@@ -799,16 +822,17 @@ let modtype_of_package env loc p nl tl =
         (List.combine (List.map Longident.flatten nl) tl)
   | _ ->
       if nl = [] then Mty_ident p
-      else raise(Error(loc, Signature_expected))
+      else raise(Error(loc, env, Signature_expected))
   with Not_found ->
-    raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
+    let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in
+    raise(Typetexp.Error(loc, env, error))
 
 let wrap_constraint env arg mty explicit =
   let coercion =
     try
       Includemod.modtypes env arg.mod_type mty
     with Includemod.Error msg ->
-      raise(Error(arg.mod_loc, Not_included msg)) in
+      raise(Error(arg.mod_loc, env, Not_included msg)) in
   { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
     mod_type = mty;
     mod_env = env;
@@ -816,11 +840,6 @@ let wrap_constraint env arg mty explicit =
 
 (* Type a module value expression *)
 
-let mkstr desc loc env =
-  let str = { str_desc = desc; str_loc = loc; str_env = env } in
-  Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str);
-  str
-
 let rec type_module sttn funct_body anchor env smod =
   match smod.pmod_desc with
     Pmod_ident lid ->
@@ -855,7 +874,7 @@ let rec type_module sttn funct_body anchor env smod =
             try
               Includemod.modtypes env arg.mod_type mty_param
             with Includemod.Error msg ->
-              raise(Error(sarg.pmod_loc, Not_included msg)) in
+              raise(Error(sarg.pmod_loc, env, Not_included msg)) in
           let mty_appl =
             match path with
               Some path ->
@@ -866,7 +885,7 @@ let rec type_module sttn funct_body anchor env smod =
                   Mtype.nondep_supertype
                     (Env.add_module param arg.mod_type env) param mty_res
                 with Not_found ->
-                  raise(Error(smod.pmod_loc,
+                  raise(Error(smod.pmod_loc, env,
                               Cannot_eliminate_dependency mty_functor))
           in
           rm { mod_desc = Tmod_apply(funct, arg, coercion);
@@ -874,7 +893,7 @@ let rec type_module sttn funct_body anchor env smod =
                mod_env = env;
                mod_loc = smod.pmod_loc }
       | _ ->
-          raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
+          raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
       end
   | Pmod_constraint(sarg, smty) ->
       let arg = type_module true funct_body anchor env sarg in
@@ -884,7 +903,7 @@ let rec type_module sttn funct_body anchor env smod =
 
   | Pmod_unpack sexp ->
       if funct_body then
-        raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
+        raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
       if !Clflags.principal then Ctype.begin_def ();
       let exp = Typecore.type_exp env sexp in
       if !Clflags.principal then begin
@@ -895,7 +914,7 @@ let rec type_module sttn funct_body anchor env smod =
         match Ctype.expand_head env exp.exp_type with
           {desc = Tpackage (p, nl, tl)} ->
             if List.exists (fun t -> Ctype.free_variables t <> []) tl then
-              raise (Error (smod.pmod_loc,
+              raise (Error (smod.pmod_loc, env,
                             Incomplete_packed_module exp.exp_type));
             if !Clflags.principal &&
               not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
@@ -905,9 +924,9 @@ let rec type_module sttn funct_body anchor env smod =
             modtype_of_package env smod.pmod_loc p nl tl
         | {desc = Tvar _} ->
             raise (Typecore.Error
-                     (smod.pmod_loc, Typecore.Cannot_infer_signature))
+                     (smod.pmod_loc, env, Typecore.Cannot_infer_signature))
         | _ ->
-            raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
+            raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type))
       in
       rm { mod_desc = Tmod_unpack(exp, mty);
            mod_type = mty;
@@ -919,18 +938,25 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
   and module_names = ref StringSet.empty
   and modtype_names = ref StringSet.empty in
   let rec type_struct env sstr =
-    let mkstr desc loc = mkstr desc loc env in
+    let previous_saved_types = Cmt_format.get_saved_types () in
     Ctype.init_def(Ident.current_time());
     match sstr with
       [] ->
         ([], [], env)
       | pstr :: srem ->
           let loc = pstr.pstr_loc in
+          let mk desc =
+            let str = { str_desc = desc; str_loc = loc; str_env = env } in
+            Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str
+                                        :: previous_saved_types);
+            str
+          in
             match pstr.pstr_desc with
               | Pstr_eval sexpr ->
                   let expr = Typecore.type_expression env sexpr in
+                  let item = mk (Tstr_eval expr) in
                   let (str_rem, sig_rem, final_env) = type_struct env srem in
-                    (mkstr (Tstr_eval expr) loc :: str_rem, sig_rem, final_env)
+                  (item :: str_rem, sig_rem, final_env)
               | Pstr_value(rec_flag, sdefs) ->
         let scope =
           match rec_flag with
@@ -945,47 +971,50 @@ 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 item = mk (Tstr_value(rec_flag, defs)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         let bound_idents = let_bound_idents 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. *)
         let make_sig_value id =
           Sig_value(id, Env.find_value (Pident id) newenv) in
-        (mkstr (Tstr_value(rec_flag, defs)) loc :: str_rem,
+        (item :: str_rem,
          map_end make_sig_value bound_idents sig_rem,
          final_env)
     | Pstr_primitive(name, sdesc) ->
         let desc = Typedecl.transl_value_decl env loc sdesc in
         let (id, newenv) = Env.enter_value name.txt desc.val_val env
             ~check:(fun s -> Warnings.Unused_value_declaration s) in
+        let item = mk (Tstr_primitive(id, name, desc)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_primitive(id, name, desc)) loc :: str_rem,
-         Sig_value(id, desc.val_val) :: sig_rem,
-         final_env)
+        (item :: str_rem, Sig_value(id, desc.val_val) :: sig_rem, final_env)
     | Pstr_type sdecls ->
         List.iter
           (fun (name, decl) -> check "type" loc type_names name.txt)
           sdecls;
         let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
+        let item = mk (Tstr_type decls) in
         let newenv' =
           enrich_type_decls anchor decls env newenv in
         let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
-        (mkstr (Tstr_type decls) loc :: str_rem,
+        (item :: str_rem,
          map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs))
            decls sig_rem,
          final_env)
     | Pstr_exception(name, sarg) ->
         let arg = Typedecl.transl_exception env loc sarg in
         let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in
+        let item = mk (Tstr_exception(id, name, arg)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_exception(id, name, arg)) loc :: str_rem,
+        (item :: str_rem,
          Sig_exception(id, arg.exn_exn) :: sig_rem,
          final_env)
     | Pstr_exn_rebind(name, longid) ->
         let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
         let (id, newenv) = Env.enter_exception name.txt arg env in
+        let item = mk (Tstr_exn_rebind(id, name, path, longid)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_exn_rebind(id, name, path, longid)) loc :: str_rem,
+        (item :: str_rem,
          Sig_exception(id, arg) :: sig_rem,
          final_env)
     | Pstr_module(name, smodl) ->
@@ -995,8 +1024,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
             smodl in
         let mty = enrich_module_type anchor name.txt modl.mod_type env in
         let (id, newenv) = Env.enter_module name.txt mty env in
+        let item = mk (Tstr_module(id, name, modl)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_module(id, name, modl)) loc :: str_rem,
+        (item :: str_rem,
          Sig_module(id, modl.mod_type, Trec_not) :: sig_rem,
          final_env)
     | Pstr_recmodule sbind ->
@@ -1019,8 +1049,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
            decls sbind in
         let bindings2 =
           check_recmodule_inclusion newenv bindings1 in
+        let item = mk (Tstr_recmodule bindings2) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_recmodule bindings2) loc :: str_rem,
+        (item :: str_rem,
          map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs))
                  bindings2 sig_rem,
          final_env)
@@ -1029,24 +1060,27 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         let mty = transl_modtype env smty in
         let (id, newenv) =
           Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in
+        let item = mk (Tstr_modtype(id, name, mty)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-        (mkstr (Tstr_modtype(id, name, mty)) loc :: str_rem,
+        (item :: str_rem,
          Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem,
          final_env)
-    | Pstr_open (lid) ->
-        let (path, newenv) = type_open ~toplevel env loc lid in
+    | Pstr_open (ovf, lid) ->
+        let (path, newenv) = type_open ovf ~toplevel env loc lid in
+        let item = mk (Tstr_open (ovf, path, lid)) in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
-          (mkstr (Tstr_open (path, lid)) loc :: str_rem, sig_rem, final_env)
+        (item :: str_rem, sig_rem, final_env)
     | Pstr_class cl ->
          List.iter
            (fun {pci_name = name} -> check "type" loc type_names name.txt)
            cl;
         let (classes, new_env) = Typeclass.class_declarations env cl in
-        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
-        (mkstr (Tstr_class
-           (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) ->
-              let vf = if d.cty_new = None then Virtual else Concrete in
-              (* (i, s, m, c, vf) *) (c, m, vf)) classes)) loc ::
+        let item =
+          mk
+            (Tstr_class
+               (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) ->
+                 let vf = if d.cty_new = None then Virtual else Concrete in
+                 (* (i, s, m, c, vf) *) (c, m, vf)) classes))
 (* TODO: check with Jacques why this is here
            Tstr_class_type
            (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
@@ -1055,14 +1089,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
          Tstr_type
            (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
 *)
-         str_rem,
+        in
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (item :: str_rem,
          List.flatten
            (map_rec
               (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                 [Sig_class(i, d, rs);
-                  Sig_class_type(i', d', rs);
-                  Sig_type(i'', d'', rs);
-                  Sig_type(i''', d''', rs)])
+                [Sig_class(i, d, rs);
+                 Sig_class_type(i', d', rs);
+                 Sig_type(i'', d'', rs);
+                 Sig_type(i''', d''', rs)])
               classes [sig_rem]),
          final_env)
     | Pstr_class_type cl ->
@@ -1070,16 +1106,19 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           (fun {pci_name = name} -> check "type" loc type_names name.txt)
           cl;
         let (classes, new_env) = Typeclass.class_type_declarations env cl in
-        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
-        (mkstr (Tstr_class_type
-           (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
-             (i, i_loc, c)) classes)) loc ::
+        let item =
+          mk
+            (Tstr_class_type
+               (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
+                 (i, i_loc, c)) classes))
 (*  TODO: check with Jacques why this is here
        Tstr_type
            (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
          Tstr_type
            (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
-         str_rem,
+        in
+        let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+        (item :: str_rem,
          List.flatten
            (map_rec
               (fun rs (i, _, d, i', d', i'', d'', _) ->
@@ -1096,8 +1135,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         List.iter
           (check_sig_item type_names module_names modtype_names loc) sg;
         let new_env = Env.add_signature sg env in
+        let item = mk (Tstr_include (modl, sg)) in
         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
-        (mkstr (Tstr_include (modl, bound_value_identifiers sg)) loc :: str_rem,
+        (item :: str_rem,
          sg @ sig_rem,
          final_env)
   in
@@ -1111,7 +1151,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     (Cmt_format.Partial_structure str :: previous_saved_types);
   str, sg, final_env
 
-let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none
+let type_toplevel_phrase env s =
+  type_structure ~toplevel:true false None env s Location.none
 let type_module = type_module true false None
 let type_structure = type_structure false None
 
@@ -1178,7 +1219,7 @@ let type_module_type_of env smod =
   let mty = simplify_modtype mty in
   (* PR#5036: must not contain non-generalized type variables *)
   if not (closed_modtype mty) then
-    raise(Error(smod.pmod_loc, Non_generalizable_module mty));
+    raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
   tmty, mty
 
 (* For Typecore *)
@@ -1221,7 +1262,8 @@ let type_package env m p nl tl =
   List.iter2
     (fun n ty ->
       try Ctype.unify env ty (Ctype.newvar ())
-      with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty))))
+      with Ctype.Unify _ ->
+        raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
     nl tl';
   (wrap_constraint env modl mty Tmodtype_implicit, tl')
 
@@ -1240,10 +1282,12 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   Cmt_format.set_saved_types [];
   try
   Typecore.reset_delayed_checks ();
-  let (str, sg, finalenv) = type_structure initial_env ast Location.none in
+  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
-    fprintf std_formatter "%a@." Printtyp.signature simple_sg;
+    Printtyp.wrap_printing_env initial_env
+      (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
   end else begin
     let sourceintf =
@@ -1253,7 +1297,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
         try
           find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
         with Not_found ->
-          raise(Error(Location.none, Interface_not_compiled sourceintf)) in
+          raise(Error(Location.in_file sourcefile, Env.empty,
+                      Interface_not_compiled sourceintf)) in
       let dclsig = Env.read_signature modulename intf_file in
       let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
       Typecore.force_delayed_checks ();
@@ -1318,7 +1363,8 @@ let package_units objfiles cmifile modulename =
          let sg = Env.read_signature modname (pref ^ ".cmi") in
          if Filename.check_suffix f ".cmi" &&
             not(Mtype.no_code_needed_sig Env.initial sg)
-         then raise(Error(Location.none, Implementation_is_required f));
+         then raise(Error(Location.none, Env.empty,
+                          Implementation_is_required f));
          (modname, Env.read_signature modname (pref ^ ".cmi")))
       objfiles in
   (* Compute signature of packaged unit *)
@@ -1329,7 +1375,8 @@ let package_units objfiles cmifile modulename =
   let mlifile = prefix ^ !Config.interface_suffix in
   if Sys.file_exists mlifile then begin
     if not (Sys.file_exists cmifile) then begin
-      raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile))
+      raise(Error(Location.in_file mlifile, Env.empty,
+                  Interface_not_compiled mlifile))
     end;
     let dclsig = Env.read_signature modulename cmifile in
     Cmt_format.save_cmt  (prefix ^ ".cmt") modulename
@@ -1430,3 +1477,6 @@ let report_error ppf = function
         "The type %a in this module cannot be exported.@ " longident lid;
       fprintf ppf
         "Its type contains local dependencies:@ %a" type_expr ty
+
+let report_error env ppf err =
+  Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 5042c65c..cda00694 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typemod.mli 12542 2012-06-01 14:06:31Z frisch $ *)
-
 (* Type-checking of the module language *)
 
 open Types
@@ -41,8 +39,6 @@ val save_signature : string -> Typedtree.signature -> string -> string ->
 val package_units:
         string list -> string -> string -> Typedtree.module_coercion
 
-val bound_value_identifiers : Types.signature_item list -> Ident.t list
-
 type error =
     Cannot_apply of module_type
   | Not_included of Includemod.error list
@@ -63,6 +59,6 @@ type error =
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit
diff --git a/typing/types.ml b/typing/types.ml
index 1f5c9207..117595f8 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -10,11 +10,8 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: types.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Representation of types and declarations *)
 
-open Misc
 open Asttypes
 
 (* Type expressions for the core language *)
@@ -79,7 +76,8 @@ end
 
 (* Maps of methods and instance variables *)
 
-module OrderedString = struct type t = string let compare = compare end
+module OrderedString =
+  struct type t = string let compare (x:t) y = compare x y end
 module Meths = Map.Make(OrderedString)
 module Vars = Meths
 
@@ -107,7 +105,8 @@ and value_kind =
 (* Constructor descriptions *)
 
 type constructor_description =
-  { cstr_res: type_expr;                (* Type of the result *)
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
     cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
@@ -139,6 +138,36 @@ and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
 
+(* Variance *)
+
+module Variance = struct
+  type t = int
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
+  let subset v1 v2 = (v1 land v2 = v1)
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
+  let null = 0
+  let may_inv = 7
+  let full = 127
+  let covariant = single May_pos lor single Pos lor single Inj
+  let swap f1 f2 v =
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
+end
+
 (* Type definitions *)
 
 type type_declaration =
@@ -147,8 +176,7 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list;
-    (* covariant, contravariant, weakly contravariant *)
+    type_variance: Variance.t list;
     type_newtype_level: (int * int) option;
     type_loc: Location.t }
 
@@ -158,6 +186,11 @@ and type_kind =
       (Ident.t * mutable_flag * type_expr) list * record_representation
   | Type_variant of (Ident.t * type_expr list * type_expr option) list
 
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
 type exception_declaration =
     { exn_args: type_expr list;
       exn_loc: Location.t }
@@ -183,13 +216,13 @@ type class_declaration =
     mutable cty_type: class_type;
     cty_path: Path.t;
     cty_new: type_expr option;
-    cty_variance: (bool * bool) list }
+    cty_variance: Variance.t list }
 
 type class_type_declaration =
   { clty_params: type_expr list;
     clty_type: class_type;
     clty_path: Path.t;
-    clty_variance: (bool * bool) list }
+    clty_variance: Variance.t list }
 
 (* Type expressions for the module language *)
 
diff --git a/typing/types.mli b/typing/types.mli
index 1bd46ada..ef02bf67 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: types.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Representation of types and declarations *)
 
 open Asttypes
@@ -104,7 +102,8 @@ and value_kind =
 (* Constructor descriptions *)
 
 type constructor_description =
-  { cstr_res: type_expr;                (* Type of the result *)
+  { cstr_name: string;                  (* Constructor name *)
+    cstr_res: type_expr;                (* Type of the result *)
     cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
@@ -136,6 +135,25 @@ and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
 
+(* Variance *)
+
+module Variance : sig
+  type t
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  val null : t                          (* no occurence *)
+  val full : t                          (* strictly invariant *)
+  val covariant : t                     (* strictly covariant *)
+  val may_inv : t                       (* maybe invariant *)
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
+  val subset : t -> t -> bool
+  val set : f -> bool -> t -> t
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
+  val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
+end
+
 (* Type definitions *)
 
 type type_declaration =
@@ -144,8 +162,8 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list;
-    (* covariant, contravariant, weakly contravariant *)
+    type_variance: Variance.t list;
+    (* covariant, contravariant, weakly contravariant, injective *)
     type_newtype_level: (int * int) option;
     (* definition level * expansion level *)
     type_loc: Location.t }
@@ -156,6 +174,11 @@ and type_kind =
       (Ident.t * mutable_flag * type_expr) list * record_representation
   | Type_variant of (Ident.t * type_expr list * type_expr option) list
 
+and type_transparence =
+    Type_public      (* unrestricted expansion *)
+  | Type_new         (* "new" type *)
+  | Type_private     (* private type *)
+
 type exception_declaration =
     { exn_args: type_expr list;
       exn_loc: Location.t }
@@ -180,13 +203,13 @@ type class_declaration =
     mutable cty_type: class_type;
     cty_path: Path.t;
     cty_new: type_expr option;
-    cty_variance: (bool * bool) list }
+    cty_variance: Variance.t list }
 
 type class_type_declaration =
   { clty_params: type_expr list;
     clty_type: class_type;
     clty_path: Path.t;
-    clty_variance: (bool * bool) list }
+    clty_variance: Variance.t list }
 
 (* Type expressions for the module language *)
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index aa8b7c6a..f9c0ecd7 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -50,8 +50,9 @@ type error =
   | Unbound_modtype of Longident.t
   | Unbound_cltype of Longident.t
   | Ill_typed_functor_application of Longident.t
+  | Illegal_reference_to_recursive_module
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
 type variable_context = int * (string, type_expr) Tbl.t
 
@@ -61,12 +62,15 @@ let instance_list = Ctype.instance_list Env.empty
 
 (* Narrowing unbound identifier errors. *)
 
-let rec narrow_unbound_lid_error env loc lid make_error =
+let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
+  fun env loc lid make_error ->
   let check_module mlid =
     try ignore (Env.lookup_module mlid env)
     with Not_found ->
-      narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid);
-      assert false
+      narrow_unbound_lid_error env loc mlid
+        (fun lid -> Unbound_module lid)
+       | Env.Recmodule ->
+         raise (Error (loc, env, Illegal_reference_to_recursive_module))
   in
   begin match lid with
   | Longident.Lident _ -> ()
@@ -74,9 +78,9 @@ let rec narrow_unbound_lid_error env loc lid make_error =
   | Longident.Lapply (flid, mlid) ->
       check_module flid;
       check_module mlid;
-      raise (Error (loc, Ill_typed_functor_application lid))
+      raise (Error (loc, env, Ill_typed_functor_application lid))
   end;
-  raise (Error (loc, make_error lid))
+  raise (Error (loc, env, make_error lid))
 
 let find_component lookup make_error env loc lid =
   try
@@ -85,16 +89,21 @@ let find_component lookup make_error env loc lid =
         lookup (Longident.Lident s) Env.initial
     | _ -> lookup lid env
   with Not_found ->
-    (narrow_unbound_lid_error env loc lid make_error
-     : unit (* to avoid a warning *));
-    assert false
+    narrow_unbound_lid_error env loc lid make_error
+  | Env.Recmodule ->
+    raise (Error (loc, env, Illegal_reference_to_recursive_module))
 
 let find_type =
   find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
 let find_constructor =
   find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
+let find_all_constructors =
+  find_component Env.lookup_all_constructors
+    (fun lid -> Unbound_constructor lid)
 let find_label =
   find_component Env.lookup_label (fun lid -> Unbound_label lid)
+let find_all_labels =
+  find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)
 let find_class =
   find_component Env.lookup_class (fun lid -> Unbound_class lid)
 let find_value =
@@ -106,6 +115,14 @@ let find_modtype =
 let find_class_type =
   find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
 
+let unbound_constructor_error env lid =
+  narrow_unbound_lid_error env lid.loc lid.txt
+    (fun lid -> Unbound_constructor lid)
+
+let unbound_label_error env lid =
+  narrow_unbound_lid_error env lid.loc lid.txt
+    (fun lid -> Unbound_label lid)
+
 (* Support for first-class modules. *)
 
 let transl_modtype_longident = ref (fun _ -> assert false)
@@ -116,7 +133,7 @@ let create_package_mty fake loc env (p, l) =
     List.sort
       (fun (s1, t1) (s2, t2) ->
          if s1.txt = s2.txt then
-           raise (Error (loc, Multiple_constraints_on_type s1.txt));
+           raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
          compare s1 s2)
       l
   in
@@ -169,7 +186,7 @@ let newvar ?name () =
 let enter_type_variable strict loc name =
   try
     if name <> "" && name.[0] = '_' then
-      raise (Error (loc, Invalid_variable_name ("'" ^ name)));
+      raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name)));
     let v = Tbl.find name !type_variables in
     if strict then raise Already_bound;
     v
@@ -182,7 +199,7 @@ let type_variable loc name =
   try
     Tbl.find name !type_variables
   with Not_found ->
-    raise(Error(loc, Unbound_type_variable ("'" ^ name)))
+    raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name)))
 
 let wrap_method ty =
   match (Ctype.repr ty).desc with
@@ -208,14 +225,14 @@ let rec transl_type env policy styp =
       let ty =
         if policy = Univars then new_pre_univar () else
           if policy = Fixed then
-            raise (Error (styp.ptyp_loc, Unbound_type_variable "_"))
+            raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_"))
           else newvar ()
       in
       ctyp Ttyp_any ty env loc
   | Ptyp_var name ->
     let ty =
       if name <> "" && name.[0] = '_' then
-        raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
+        raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name)));
       begin try
         instance env (List.assoc name !univars)
       with Not_found -> try
@@ -241,8 +258,9 @@ let rec transl_type env policy styp =
   | Ptyp_constr(lid, stl) ->
       let (path, decl) = find_type env styp.ptyp_loc lid.txt in
       if List.length stl <> decl.type_arity then
-        raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity,
-                                                           List.length stl)));
+        raise(Error(styp.ptyp_loc, env,
+		    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
       let args = List.map (transl_type env policy) stl in
       let params = instance_list decl.type_params in
       let unify_param =
@@ -254,14 +272,14 @@ let rec transl_type env policy styp =
       List.iter2
         (fun (sty, cty) ty' ->
            try unify_param env ty' cty.ctyp_type with Unify trace ->
-             raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       let constr =
         newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in
       begin try
         Ctype.enforce_constraints env constr
       with Unify trace ->
-        raise (Error(styp.ptyp_loc, Type_mismatch trace))
+        raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
       end;
         ctyp (Ttyp_constr (path, lid, args)) constr env loc
   | Ptyp_object fields ->
@@ -292,7 +310,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;
+          Location.prerr_warning styp.ptyp_loc
+            (Warnings.Deprecated "old syntax for polymorphic variant type");
           (path, decl,true)
         with Not_found -> try
           if present <> [] then raise Not_found;
@@ -305,30 +324,31 @@ let rec transl_type env policy styp =
           let (path, decl) = Env.lookup_type lid2 env in
           (path, decl, false)
         with Not_found ->
-          raise(Error(styp.ptyp_loc, Unbound_class lid.txt))
+          raise(Error(styp.ptyp_loc, env, Unbound_class lid.txt))
       in
       if List.length stl <> decl.type_arity then
-        raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity,
-                                                       List.length stl)));
+        raise(Error(styp.ptyp_loc, env,
+                    Type_arity_mismatch(lid.txt, decl.type_arity,
+                                        List.length stl)));
       let args = List.map (transl_type env policy) stl in
       let params = instance_list decl.type_params in
       List.iter2
         (fun (sty, cty) ty' ->
            try unify_var env ty' cty.ctyp_type with Unify trace ->
-             raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+             raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
         let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
       let ty =
         try Ctype.expand_head env (newconstr path ty_args)
         with Unify trace ->
-          raise (Error(styp.ptyp_loc, Type_mismatch trace))
+          raise (Error(styp.ptyp_loc, env, Type_mismatch trace))
       in
       let ty = match ty.desc with
         Tvariant row ->
           let row = Btype.row_repr row in
           List.iter
             (fun l -> if not (List.mem_assoc l row.row_fields) then
-              raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
             present;
           let fields =
             List.map
@@ -371,7 +391,7 @@ let rec transl_type env policy styp =
           let ty = transl_type env policy st in
           begin try unify_var env t ty.ctyp_type with Unify trace ->
             let trace = swap_list trace in
-            raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
           end;
           ty
         with Not_found ->
@@ -381,7 +401,7 @@ let rec transl_type env policy styp =
           let ty = transl_type env policy st in
           begin try unify_var env t ty.ctyp_type with Unify trace ->
             let trace = swap_list trace in
-            raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+            raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace))
           end;
           if !Clflags.principal then begin
             end_def ();
@@ -409,15 +429,16 @@ let rec transl_type env policy styp =
         try
           let (l',f') = Hashtbl.find hfields h in
           (* Check for tag conflicts *)
-          if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l')));
+          if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l')));
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
-          with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty')))
+          with Unify trace ->
+            raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
           Hashtbl.add hfields h (l,f)
       in
-      let rec add_field = function
+      let add_field = function
           Rtag (l, c, stl) ->
             name := None;
             let tl = List.map (transl_type env policy) stl in
@@ -427,7 +448,7 @@ let rec transl_type env policy styp =
                 Reither(c, ty_tl, false, ref None)
             | _ ->
                 if List.length stl > 1 || c && stl <> [] then
-                  raise(Error(styp.ptyp_loc, Present_has_conjunction l));
+                  raise(Error(styp.ptyp_loc, env, Present_has_conjunction l));
                 match tl with [] -> Rpresent None
                 | st :: _ ->
                       Rpresent (Some st.ctyp_type)
@@ -455,9 +476,9 @@ let rec transl_type env policy styp =
                 let row = Btype.row_repr row in
                 row.row_fields
             | {desc=Tvar _}, Some(p, _) ->
-                raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
+                raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p))
             | _ ->
-                raise(Error(sty.ptyp_loc, Not_a_variant ty))
+                raise(Error(sty.ptyp_loc, env, Not_a_variant ty))
             in
             List.iter
               (fun (l, f) ->
@@ -483,7 +504,7 @@ let rec transl_type env policy styp =
       | Some present ->
           List.iter
             (fun l -> if not (List.mem_assoc l fields) then
-              raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+              raise(Error(styp.ptyp_loc, env, Present_has_no_type l)))
             present
       end;
       let row =
@@ -518,7 +539,7 @@ let rec transl_type env policy styp =
                   v.desc <- Tunivar name;
                   v :: tyl
               | _ ->
-                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
+                raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v)))
             end else tyl)
           [] new_univars
       in
@@ -552,7 +573,7 @@ and transl_fields env policy seen =
   | {field_desc = Tcfield_var}::_ ->
       if policy = Univars then new_pre_univar () else newvar ()
   | {field_desc = Tcfield(s, ty1); field_loc = loc}::l ->
-      if List.mem s seen then  raise (Error (loc, Repeated_method_label s));
+      if List.mem s seen then raise (Error (loc, env, Repeated_method_label s));
       let ty2 = transl_fields env policy (s::seen) l in
         newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
 
@@ -594,7 +615,7 @@ let globalize_used_variables env fixed =
         r := (loc, v,  Tbl.find name !type_variables) :: !r
       with Not_found ->
         if fixed && Btype.is_Tvar (repr ty) then
-          raise(Error(loc, Unbound_type_variable ("'"^name)));
+          raise(Error(loc, env, Unbound_type_variable ("'"^name)));
         let v2 = new_global_var () in
         r := (loc, v, v2) :: !r;
         type_variables := Tbl.add name v2 !type_variables)
@@ -604,7 +625,7 @@ let globalize_used_variables env fixed =
     List.iter
       (function (loc, t1, t2) ->
         try unify env t1 t2 with Unify trace ->
-          raise (Error(loc, Type_mismatch trace)))
+          raise (Error(loc, env, Type_mismatch trace)))
       !r
 
 let transl_simple_type env fixed styp =
@@ -663,37 +684,87 @@ let transl_type_scheme env styp =
 open Format
 open Printtyp
 
-let report_error ppf = function
+let spellcheck ppf fold env lid =
+  let cutoff =
+    match String.length (Longident.last lid) with
+      | 1 | 2 -> 0
+      | 3 | 4 -> 1
+      | 5 | 6 -> 2
+      | _ -> 3
+  in
+  let compare target head acc =
+    let (best_choice, best_dist) = acc in
+    match Misc.edit_distance target head cutoff with
+      | None -> (best_choice, best_dist)
+      | Some dist ->
+        let choice =
+          if dist < best_dist then [head]
+          else if dist = best_dist then head :: best_choice
+          else best_choice in
+        (choice, min dist best_dist)
+  in
+  let init = ([], max_int) in
+  let handle (choice, _dist) =
+    match List.rev choice with
+      | [] -> ()
+      | last :: rev_rest ->
+        fprintf ppf "@\nDid you mean %s%s%s?"
+          (String.concat ", " (List.rev rev_rest))
+          (if rev_rest = [] then "" else " or ")
+          last
+  in
+  (* flush now to get the error report early, in the (unheard of) case
+     where the linear search would take a bit of time; in the worst
+     case, the user has seen the error, she can interrupt the process
+     before the spell-checking terminates. *)
+  fprintf ppf "@?";
+  match lid with
+    | Longident.Lapply _ -> ()
+    | Longident.Lident s ->
+      handle (fold (compare s) None env init)
+    | Longident.Ldot (r, s) ->
+      handle (fold (compare s) (Some r) env init)
+
+let spellcheck_simple ppf fold extr =
+  spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x))
+
+let spellcheck ppf fold =
+  spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
+
+type cd = string list * int
+
+let report_error env ppf = function
   | Unbound_type_variable name ->
-      fprintf ppf "Unbound type parameter %s" name
+    fprintf ppf "Unbound type parameter %s@." name
   | Unbound_type_constructor lid ->
-      fprintf ppf "Unbound type constructor %a" longident lid
+    fprintf ppf "Unbound type constructor %a" longident lid;
+    spellcheck ppf Env.fold_types env lid;
   | Unbound_type_constructor_2 p ->
-      fprintf ppf "The type constructor@ %a@ is not yet completely defined"
-        path p
+    fprintf ppf "The type constructor@ %a@ is not yet completely defined"
+      path p
   | Type_arity_mismatch(lid, expected, provided) ->
-      fprintf ppf
-       "@[The type constructor %a@ expects %i argument(s),@ \
+    fprintf ppf
+      "@[The type constructor %a@ expects %i argument(s),@ \
         but is here applied to %i argument(s)@]"
-       longident lid expected provided
+      longident lid expected provided
   | Bound_type_variable name ->
-      fprintf ppf "Already bound type parameter '%s" name
+    fprintf ppf "Already bound type parameter '%s" name
   | Recursive_type ->
-      fprintf ppf "This type is recursive"
+    fprintf ppf "This type is recursive"
   | Unbound_row_variable lid ->
+      (* we don't use "spellcheck" here: this error is not raised
+         anywhere so it's unclear how it should be handled *)
       fprintf ppf "Unbound row variable in #%a" longident lid
   | Type_mismatch trace ->
-      Printtyp.unification_error true trace
+      Printtyp.report_unification_error ppf Env.empty trace
         (function ppf ->
            fprintf ppf "This type")
-        ppf
         (function ppf ->
            fprintf ppf "should be an instance of type")
   | Alias_type_mismatch trace ->
-      Printtyp.unification_error true trace
+      Printtyp.report_unification_error ppf Env.empty trace
         (function ppf ->
            fprintf ppf "This alias is bound to type")
-        ppf
         (function ppf ->
            fprintf ppf "but is used as an instance of type")
   | Present_has_conjunction l ->
@@ -701,12 +772,13 @@ let report_error ppf = function
   | Present_has_no_type l ->
       fprintf ppf "The present constructor %s has no type" l
   | Constructor_mismatch (ty, ty') ->
-      Printtyp.reset_and_mark_loops_list [ty; ty'];
-      fprintf ppf "@[%s %a@ %s@ %a@]"
-        "This variant type contains a constructor"
-        Printtyp.type_expr ty
-        "which should be"
-        Printtyp.type_expr ty'
+      wrap_printing_env env (fun ()  ->
+	Printtyp.reset_and_mark_loops_list [ty; ty'];
+	fprintf ppf "@[%s %a@ %s@ %a@]"
+          "This variant type contains a constructor"
+          Printtyp.type_expr ty
+          "which should be"
+          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@]"
@@ -730,18 +802,28 @@ let report_error ppf = function
       fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
         s "Multiple occurences are not allowed."
   | Unbound_value lid ->
-      fprintf ppf "Unbound value %a" longident lid
+      fprintf ppf "Unbound value %a" longident lid;
+      spellcheck ppf Env.fold_values env lid;
   | Unbound_module lid ->
-      fprintf ppf "Unbound module %a" longident lid
+      fprintf ppf "Unbound module %a" longident lid;
+      spellcheck ppf Env.fold_modules env lid;
   | Unbound_constructor lid ->
-      fprintf ppf "Unbound constructor %a" longident lid
+      fprintf ppf "Unbound constructor %a" longident lid;
+      spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name)
+	env lid;
   | Unbound_label lid ->
-      fprintf ppf "Unbound record field label %a" longident lid
+      fprintf ppf "Unbound record field %a" longident lid;
+      spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid;
   | Unbound_class lid ->
-      fprintf ppf "Unbound class %a" longident lid
+      fprintf ppf "Unbound class %a" longident lid;
+      spellcheck ppf Env.fold_classs env lid;
   | Unbound_modtype lid ->
-      fprintf ppf "Unbound module type %a" longident lid
+      fprintf ppf "Unbound module type %a" longident lid;
+      spellcheck ppf Env.fold_modtypes env lid;
   | Unbound_cltype lid ->
-      fprintf ppf "Unbound class type %a" longident lid
+      fprintf ppf "Unbound class type %a" longident lid;
+      spellcheck ppf Env.fold_cltypes env lid;
   | Ill_typed_functor_application lid ->
       fprintf ppf "Ill-typed functor application %a" longident lid
+  | Illegal_reference_to_recursive_module ->
+      fprintf ppf "Illegal recursive module reference"
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index bf20894e..66ffb7b8 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -10,11 +10,9 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typetexp.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
-
 (* Typechecking of type expressions for the core language *)
 
-open Format;;
+open Types
 
 val transl_simple_type:
         Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type
@@ -27,8 +25,8 @@ val transl_simple_type_delayed:
 val transl_type_scheme:
         Env.t -> Parsetree.core_type -> Typedtree.core_type
 val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> Location.t -> string -> Types.type_expr
-val type_variable: Location.t -> string -> Types.type_expr
+val enter_type_variable: bool -> Location.t -> string -> type_expr
+val type_variable: Location.t -> string -> type_expr
 
 type variable_context
 val narrow: unit -> variable_context
@@ -44,15 +42,15 @@ type error =
   | Bound_type_variable of string
   | Recursive_type
   | Unbound_row_variable of Longident.t
-  | Type_mismatch of (Types.type_expr * Types.type_expr) list
-  | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list
+  | Type_mismatch of (type_expr * type_expr) list
+  | Alias_type_mismatch of (type_expr * type_expr) list
   | Present_has_conjunction of string
   | Present_has_no_type of string
-  | Constructor_mismatch of Types.type_expr * Types.type_expr
-  | Not_a_variant of Types.type_expr
+  | Constructor_mismatch of type_expr * type_expr
+  | Not_a_variant of type_expr
   | Variant_tags of string * string
   | Invalid_variable_name of string
-  | Cannot_quantify of string * Types.type_expr
+  | Cannot_quantify of string * type_expr
   | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
@@ -63,10 +61,11 @@ type error =
   | Unbound_modtype of Longident.t
   | Unbound_cltype of Longident.t
   | Ill_typed_functor_application of Longident.t
+  | Illegal_reference_to_recursive_module
 
-exception Error of Location.t * error
+exception Error of Location.t * Env.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> Format.formatter -> error -> unit
 
 (* Support for first-class modules. *)
 val transl_modtype_longident:  (* from Typemod *)
@@ -79,18 +78,33 @@ val create_package_mty:
       Parsetree.module_type
 
 val find_type:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t * type_declaration
 val find_constructor:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.constructor_description
+    Env.t -> Location.t -> Longident.t -> constructor_description
+val find_all_constructors:
+    Env.t -> Location.t -> Longident.t -> 
+    (constructor_description * (unit -> unit)) list
 val find_label:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.label_description
+    Env.t -> Location.t -> Longident.t -> label_description
+val find_all_labels:
+    Env.t -> Location.t -> Longident.t -> 
+    (label_description * (unit -> unit)) list
 val find_value:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description
+    Env.t -> Location.t -> Longident.t -> Path.t * value_description
 val find_class:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
 val find_module:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type
+    Env.t -> Location.t -> Longident.t -> Path.t * module_type
 val find_modtype:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
 val find_class_type:
-    Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration
+
+val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
+val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
+
+type cd
+val spellcheck_simple:
+    Format.formatter ->
+    (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) ->
+    ('a -> string) -> 'b -> Longident.t -> unit
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index ebb382f8..bbc8e3f0 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ccomp.ml 12027 2012-01-16 09:05:37Z frisch $ *)
-
 (* Compiling C files and building C libraries *)
 
 let command cmdline =
@@ -60,7 +58,7 @@ let compile_file name =
             if !Clflags.native_code
             then Config.native_c_compiler
             else Config.bytecomp_c_compiler)
-       (String.concat " " (List.rev !Clflags.ccopts))
+       (String.concat " " (List.rev !Clflags.all_ccopts))
        (quote_prefixed "-I" (List.rev !Clflags.include_dirs))
        (Clflags.std_include_flag "-I")
        (Filename.quote name))
@@ -121,7 +119,7 @@ let call_linker mode output_name files extra =
         (if !Clflags.gprofile then Config.cc_profile else "")
         ""  (*(Clflags.std_include_flag "-I")*)
         (quote_prefixed "-L" !Config.load_path)
-        (String.concat " " (List.rev !Clflags.ccopts))
+        (String.concat " " (List.rev !Clflags.all_ccopts))
         files
         extra
   in
diff --git a/utils/ccomp.mli b/utils/ccomp.mli
index a7246c91..63a190c3 100644
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ccomp.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Compiling C files and building C libraries *)
 
 val command: string -> int
diff --git a/utils/clflags.ml b/utils/clflags.ml
index d39d57af..48846b58 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: clflags.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Command-line parameters *)
 
 let objfiles = ref ([] : string list)   (* .cmo and .cma files *)
@@ -28,11 +26,13 @@ and debug = ref false                   (* -g *)
 and fast = ref false                    (* -unsafe *)
 and link_everything = ref false         (* -linkall *)
 and custom_runtime = ref false          (* -custom *)
+and bytecode_compatible_32 = ref false  (* -compat-32 *)
 and output_c_object = ref false         (* -output-obj *)
-and ccopts = ref ([] : string list)     (* -ccopt *)
+and all_ccopts = ref ([] : string list)     (* -ccopt *)
 and classic = ref false                 (* -nolabels *)
 and nopervasives = ref false            (* -nopervasives *)
 and preprocessor = ref(None : string option) (* -pp *)
+and all_ppx = ref ([] : string list)        (* -ppx *)
 let annotations = ref false             (* -annot *)
 let binary_annotations = ref false      (* -annot *)
 and use_threads = ref false             (* -thread *)
@@ -45,6 +45,7 @@ and init_file = ref (None : string option)   (* -init *)
 and use_prims = ref ""                  (* -use-prims ... *)
 and use_runtime = ref ""                (* -use-runtime ... *)
 and principal = ref false               (* -principal *)
+and real_paths = ref true               (* -short-paths *)
 and recursive_types = ref false         (* -rectypes *)
 and strict_sequence = ref false         (* -strict-sequence *)
 and applicative_functors = ref true     (* -no-app-funct *)
@@ -56,7 +57,9 @@ and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
 and error_size = ref 500                (* -error-size *)
+let dump_source = ref false             (* -dsource *)
 let dump_parsetree = ref false          (* -dparsetree *)
+and dump_typedtree = ref false          (* -dtypedtree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
 and dump_clambda = ref false            (* -dclambda *)
@@ -70,7 +73,6 @@ let dump_selection = ref false          (* -dsel *)
 let dump_live = ref false               (* -dlive *)
 let dump_spill = ref false              (* -dspill *)
 let dump_split = ref false              (* -dsplit *)
-let dump_scheduling = ref false         (* -dscheduling *)
 let dump_interf = ref false             (* -dinterf *)
 let dump_prefer = ref false             (* -dprefer *)
 let dump_regalloc = ref false           (* -dalloc *)
@@ -82,6 +84,7 @@ let dump_combine = ref false            (* -dcombine *)
 
 let native_code = ref false             (* set to true under ocamlopt *)
 let inline_threshold = ref 10
+let force_slash = ref false             (* for ocamldep *)
 
 let dont_write_files = ref false        (* set to true under ocamldoc *)
 
@@ -97,4 +100,4 @@ let std_include_dir () =
 let shared = ref false (* -shared *)
 let dlcode = ref true (* not -nodynlink *)
 
-let runtime_variant = ref "";;     (* -runtime-variant *)
+let runtime_variant = ref "";;      (* -runtime-variant *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index e717bc1a..e6711336 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: clflags.mli 12800 2012-07-30 18:59:07Z doligez $ *)
-
 val objfiles : string list ref
 val ccobjs : string list ref
 val dllibs : string list ref
@@ -25,11 +23,13 @@ val debug : bool ref
 val fast : bool ref
 val link_everything : bool ref
 val custom_runtime : bool ref
+val bytecode_compatible_32: bool ref
 val output_c_object : bool ref
-val ccopts : string list ref
+val all_ccopts : string list ref
 val classic : bool ref
 val nopervasives : bool ref
 val preprocessor : string option ref
+val all_ppx : string list ref
 val annotations : bool ref
 val binary_annotations : bool ref
 val use_threads : bool ref
@@ -42,6 +42,7 @@ val init_file : string option ref
 val use_prims : string ref
 val use_runtime : string ref
 val principal : bool ref
+val real_paths : bool ref
 val recursive_types : bool ref
 val strict_sequence : bool ref
 val applicative_functors : bool ref
@@ -53,7 +54,9 @@ val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
 val error_size : int ref
+val dump_source : bool ref
 val dump_parsetree : bool ref
+val dump_typedtree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
 val dump_clambda : bool ref
@@ -81,3 +84,4 @@ val std_include_dir : unit -> string list
 val shared : bool ref
 val dlcode : bool ref
 val runtime_variant : string ref
+val force_slash : bool ref
diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 7e02f742..422ba4ca 100644
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mlbuild 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (***********************************************************************)
 (**                                                                   **)
 (**               WARNING WARNING WARNING                             **)
@@ -49,7 +47,8 @@ let standard_runtime =
   if windows then "ocamlrun"
   else C.bindir^"/ocamlrun"
 let ccomp_type = C.ccomptype
-let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts
+let bytecomp_c_compiler =
+  sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts
 let bytecomp_c_libraries = C.bytecclibs
 let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts
 let native_c_libraries = C.nativecclibs
@@ -62,15 +61,15 @@ let mkexe = C.mkexe
 let mkmaindll = C.mkmaindll
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I014"
+and cmi_magic_number = "Caml1999I015"
 and cmo_magic_number = "Caml1999O007"
 and cma_magic_number = "Caml1999A008"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M015"
-and ast_intf_magic_number = "Caml1999N014"
+and ast_impl_magic_number = "Caml1999M016"
+and ast_intf_magic_number = "Caml1999N015"
 and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T001"
+and cmt_magic_number = "Caml2012T002"
 
 let load_path = ref ([] : string list)
 
@@ -132,5 +131,16 @@ let print_config oc =
   p "os_type" Sys.os_type;
   p "default_executable_name" default_executable_name;
   p_bool "systhread_supported" systhread_supported;
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+
   flush oc;
 ;;
diff --git a/utils/config.mli b/utils/config.mli
index 361c69f6..27d8b4fd 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* System configuration *)
 
 val version: string
@@ -36,8 +34,8 @@ val native_c_compiler: string
 val native_c_libraries: string
         (* The C libraries to link with native-code programs *)
 val native_pack_linker: string
-        (* The linker to use for packaging (ocamlopt -pack) and for partial links
-           (ocamlopt -output-obj). *)
+        (* The linker to use for packaging (ocamlopt -pack) and for partial
+           links (ocamlopt -output-obj). *)
 val mkdll: string
         (* The linker command line to build dynamic libraries. *)
 val mkexe: string
@@ -103,6 +101,8 @@ val asm: string
 
 val asm_cfi_supported: bool
         (* Whether assembler understands CFI directives *)
+val with_frame_pointers : bool
+        (* Whether assembler should maintain frame pointers *)
 
 val ext_obj: string
         (* Extension for object files, e.g. [.o] under Unix. *)
diff --git a/utils/config.mlp b/utils/config.mlp
index cdf67d44..deaa7727 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: config.mlp 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (***********************************************************************)
 (**                                                                   **)
 (**               WARNING WARNING WARNING                             **)
@@ -51,15 +49,15 @@ let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I014"
+and cmi_magic_number = "Caml1999I015"
 and cmo_magic_number = "Caml1999O007"
 and cma_magic_number = "Caml1999A008"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M015"
-and ast_intf_magic_number = "Caml1999N014"
+and ast_impl_magic_number = "Caml1999M016"
+and ast_intf_magic_number = "Caml1999N015"
 and cmxs_magic_number = "Caml2007D001"
-and cmt_magic_number = "Caml2012T001"
+and cmt_magic_number = "Caml2012T002"
 
 let load_path = ref ([] : string list)
 
@@ -80,6 +78,7 @@ let system = "%%SYSTEM%%"
 
 let asm = "%%ASM%%"
 let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
+let with_frame_pointers = %%WITH_FRAME_POINTERS%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -114,6 +113,7 @@ let print_config oc =
   p "system" system;
   p "asm" asm;
   p_bool "asm_cfi_supported" asm_cfi_supported;
+  p_bool "with_frame_pointers" with_frame_pointers;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;
@@ -121,5 +121,18 @@ let print_config oc =
   p "os_type" Sys.os_type;
   p "default_executable_name" default_executable_name;
   p_bool "systhread_supported" systhread_supported;
+
+  (* print the magic number *)
+  p "exec_magic_number" exec_magic_number;
+  p "cmi_magic_number" cmi_magic_number;
+  p "cmo_magic_number" cmo_magic_number;
+  p "cma_magic_number" cma_magic_number;
+  p "cmx_magic_number" cmx_magic_number;
+  p "cmxa_magic_number" cmxa_magic_number;
+  p "ast_impl_magic_number" ast_impl_magic_number;
+  p "ast_intf_magic_number" ast_intf_magic_number;
+  p "cmxs_magic_number" cmxs_magic_number;
+  p "cmt_magic_number" cmt_magic_number;
+
   flush oc;
 ;;
diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index e7acee91..4bc42dc5 100644
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: consistbl.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Consistency tables: for checking consistency of module CRCs *)
 
 type t = (string, Digest.t * string) Hashtbl.t
diff --git a/utils/consistbl.mli b/utils/consistbl.mli
index fa9871fe..d3f2afce 100644
--- a/utils/consistbl.mli
+++ b/utils/consistbl.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: consistbl.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Consistency tables: for checking consistency of module CRCs *)
 
 type t
diff --git a/utils/misc.ml b/utils/misc.ml
index f2adc957..1a2a8713 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: misc.ml 12800 2012-07-30 18:59:07Z doligez $ *)
-
 (* Errors *)
 
 exception Fatal_error
@@ -224,3 +222,115 @@ let thd3 (_,_,x) = x
 let fst4 (x, _, _, _) = x
 let snd4 (_,x,_, _) = x
 let thd4 (_,_,x,_) = x
+let for4 (_,_,_,x) = x
+
+
+module LongString = struct
+  type t = string array
+
+  let create str_size =
+    let tbl_size = str_size / Sys.max_string_length + 1 in
+    let tbl = Array.make tbl_size "" in
+    for i = 0 to tbl_size - 2 do
+      tbl.(i) <- String.create Sys.max_string_length;
+    done;
+    tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length);
+    tbl
+
+  let length tbl =
+    let tbl_size = Array.length tbl in
+    Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1)
+
+  let get tbl ind =
+    tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length]
+
+  let set tbl ind c =
+    tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c
+
+  let blit src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let output oc tbl pos len =
+    for i = pos to pos + len - 1 do
+      output_char oc (get tbl i)
+    done
+
+  let unsafe_blit_to_string src srcoff dst dstoff len =
+    for i = 0 to len - 1 do
+      String.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+    done
+
+  let input_bytes ic len =
+    let tbl = create len in
+    Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl;
+    tbl
+end
+
+
+let edit_distance a b cutoff =
+  let la, lb = String.length a, String.length b in
+  let cutoff =
+    (* using max_int for cutoff would cause overflows in (i + cutoff + 1);
+       we bring it back to the (max la lb) worstcase *)
+    min (max la lb) cutoff in
+  if abs (la - lb) > cutoff then None
+  else begin
+    (* initialize with 'cutoff + 1' so that not-yet-written-to cases have
+       the worst possible cost; this is useful when computing the cost of
+       a case just at the boundary of the cutoff diagonal. *)
+    let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in
+    m.(0).(0) <- 0;
+    for i = 1 to la do
+      m.(i).(0) <- i;
+    done;
+    for j = 1 to lb do
+      m.(0).(j) <- j;
+    done;
+    for i = 1 to la do
+      for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do
+        let cost = if a.[i-1] = b.[j-1] then 0 else 1 in
+        let best =
+          (* insert, delete or substitute *)
+          min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost)
+        in
+        let best =
+          (* swap two adjacent letters; we use "cost" again in case of
+             a swap between two identical letters; this is slightly
+             redundant as this is a double-substitution case, but it
+             was done this way in most online implementations and
+             imitation has its virtues *)
+          if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1])
+          then best
+          else min best (m.(i-2).(j-2) + cost)
+        in
+        m.(i).(j) <- best
+      done;
+    done;
+    let result = m.(la).(lb) in
+    if result > cutoff
+    then None
+    else Some result
+  end
+
+
+(* split a string [s] at every char [c], and return the list of sub-strings *)
+let split s c =
+  let len = String.length s in
+  let rec iter pos to_rev =
+    if pos = len then List.rev ("" :: to_rev) else
+      match try
+              Some ( String.index_from s pos c )
+        with Not_found -> None
+      with
+          Some pos2 ->
+            if pos2 = pos then iter (pos+1) ("" :: to_rev) else
+              iter (pos2+1) ((String.sub s pos (pos2-pos)) :: to_rev)
+        | None -> List.rev ( String.sub s pos (len-pos) :: to_rev )
+  in
+  iter 0 []
+
+let cut_at s c =
+  let pos = String.index s c in
+  String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
diff --git a/utils/misc.mli b/utils/misc.mli
index 6c48e403..67316365 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: misc.mli 12511 2012-05-30 13:29:48Z lefessan $ *)
-
 (* Miscellaneous useful types and functions *)
 
 val fatal_error: string -> 'a
@@ -122,3 +120,47 @@ val thd3: 'a * 'b * 'c -> 'c
 val fst4: 'a * 'b * 'c * 'd -> 'a
 val snd4: 'a * 'b * 'c * 'd -> 'b
 val thd4: 'a * 'b * 'c * 'd -> 'c
+val for4: 'a * 'b * 'c * 'd -> 'd
+
+module LongString :
+  sig
+    type t = string array
+    val create : int -> t
+    val length : t -> int
+    val get : t -> int -> char
+    val set : t -> int -> char -> unit
+    val blit : t -> int -> t -> int -> int -> unit
+    val output : out_channel -> t -> int -> int -> unit
+    val unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+    val input_bytes : in_channel -> int -> t
+  end
+
+val edit_distance : string -> string -> int -> int option
+(** [edit_distance a b cutoff] computes the edit distance between
+    strings [a] and [b]. To help efficiency, it uses a cutoff: if the
+    distance [d] is smaller than [cutoff], it returns [Some d], else
+    [None].
+
+    The distance algorithm currently used is Damerau-Levenshtein: it
+    computes the number of insertion, deletion, substitution of
+    letters, or swapping of adjacent letters to go from one word to the
+    other. The particular algorithm may change in the future.
+*)
+
+val split : string -> char -> string list
+(** [String.split string char] splits the string [string] at every char
+    [char], and returns the list of sub-strings between the chars.
+    [String.concat (String.make 1 c) (String.split s c)] is the identity.
+    @since 4.01
+ *)
+
+val cut_at : string -> char -> string * string
+(** [String.cut_at s c] returns a pair containing the sub-string before
+   the first occurrence of [c] in [s], and the sub-string after the
+   first occurrence of [c] in [s].
+   [let (before, after) = String.cut_at s c in
+    before ^ String.make 1 c ^ after] is the identity if [s] contains [c].
+
+   Raise [Not_found] if the character does not appear in the string
+   @since 4.01
+*)
diff --git a/utils/tbl.ml b/utils/tbl.ml
index 3a5285cc..265bf3b8 100644
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tbl.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 type ('a, 'b) t =
     Empty
   | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int
diff --git a/utils/tbl.mli b/utils/tbl.mli
index 34918ce8..3167aa98 100644
--- a/utils/tbl.mli
+++ b/utils/tbl.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: tbl.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Association tables from any ordered type to any type.
    We use the generic ordering to compare keys. *)
 
diff --git a/utils/terminfo.ml b/utils/terminfo.ml
index 44d553a1..509e495c 100644
--- a/utils/terminfo.ml
+++ b/utils/terminfo.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terminfo.ml 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Basic interface to the terminfo database *)
 
 type status =
diff --git a/utils/terminfo.mli b/utils/terminfo.mli
index 68d6e01b..3e8ab512 100644
--- a/utils/terminfo.mli
+++ b/utils/terminfo.mli
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: terminfo.mli 11156 2011-07-27 14:17:02Z doligez $ *)
-
 (* Basic interface to the terminfo database *)
 
 type status =
diff --git a/utils/warnings.ml b/utils/warnings.ml
index 6bc8efbe..b543f085 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -10,8 +10,6 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: warnings.ml 12504 2012-05-29 12:35:17Z frisch $ *)
-
 (* When you change this, you need to update the documentation:
    - man/ocamlc.m   in ocaml
    - man/ocamlopt.m in ocaml
@@ -22,7 +20,7 @@
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated                              (*  3 *)
+  | Deprecated of string                    (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted                          (*  6 *)
@@ -59,6 +57,13 @@ type t =
   | Unused_constructor of string * bool * bool  (* 37 *)
   | Unused_exception of string * bool       (* 38 *)
   | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool (* 40 *)
+  | Ambiguous_name of string list * string list *  bool    (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string     (* 46 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -70,7 +75,7 @@ type t =
 let number = function
   | Comment_start -> 1
   | Comment_not_end -> 2
-  | Deprecated -> 3
+  | Deprecated _ -> 3
   | Fragile_match _ -> 4
   | Partial_application -> 5
   | Labels_omitted -> 6
@@ -107,9 +112,16 @@ let number = function
   | Unused_constructor _ -> 37
   | Unused_exception _ -> 38
   | Unused_rec_flag -> 39
+  | Name_out_of_scope _ -> 40
+  | Ambiguous_name _ -> 41
+  | Disambiguated_name _ -> 42
+  | Nonoptional_label _ -> 43
+  | Open_shadow_identifier _ -> 44
+  | Open_shadow_label_constructor _ -> 45
+  | Bad_env_variable _ -> 46
 ;;
 
-let last_warning_number = 39
+let last_warning_number = 46
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -204,7 +216,7 @@ let parse_opt flags s =
 let parse_options errflag s = parse_opt (if errflag then error else active) s;;
 
 (* 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";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45";;
 let defaults_warn_error = "-a";;
 
 let () = parse_options false defaults_w;;
@@ -213,7 +225,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 -> "this syntax is deprecated."
+  | Deprecated s -> "deprecated feature: " ^ s
   | Fragile_match "" ->
       "this pattern-matching is fragile."
   | Fragile_match s ->
@@ -304,6 +316,38 @@ let message = function
         (However, this constructor appears in patterns.)"
   | Unused_rec_flag ->
       "unused rec flag."
+  | Name_out_of_scope (ty, [nm], false) ->
+      nm ^ " was selected from type " ^ ty ^
+      ".\nIt is not visible in the current scope, and will not \n\
+       be selected if the type becomes unknown."
+  | Name_out_of_scope (_, _, false) -> assert false
+  | Name_out_of_scope (ty, slist, true) ->
+      "this record of type "^ ty ^" contains fields that are \n\
+       not visible in the current scope: "
+      ^ String.concat " " slist ^ ".\n\
+       They will not be selected if the type becomes unknown."
+  | Ambiguous_name ([s], tl, false) ->
+      s ^ " belongs to several types: " ^ String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Ambiguous_name (_, _, false) -> assert false
+  | Ambiguous_name (slist, tl, true) ->
+      "these field labels belong to several types: " ^
+      String.concat " " tl ^
+      "\nThe first one was selected. Please disambiguate if this is wrong."
+  | Disambiguated_name s ->
+      "this use of " ^ s ^ " required disambiguation."
+  | Nonoptional_label s ->
+      "the label " ^ s ^ " is not optional."
+  | Open_shadow_identifier (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s identifier %s (which is later used)"
+        kind s
+  | Open_shadow_label_constructor (kind, s) ->
+      Printf.sprintf
+        "this open statement shadows the %s %s (which is later used)"
+        kind s
+  | Bad_env_variable (var, s) ->
+    Printf.sprintf "illegal environment variable %s : %s" var s
 ;;
 
 let nerrors = ref 0;;
@@ -341,7 +385,7 @@ let descriptions =
   [
     1, "Suspicious-looking start-of-comment mark.";
     2, "Suspicious-looking end-of-comment mark.";
-    3, "Deprecated syntax.";
+    3, "Deprecated feature.";
     4, "Fragile pattern matching: matching that will remain complete even\n\
    \    if additional constructors are added to one of the variant types\n\
    \    matched.";
@@ -389,6 +433,12 @@ let descriptions =
    37, "Unused constructor.";
    38, "Unused exception constructor.";
    39, "Unused rec flag.";
+   40, "Constructor or label name used out of scope.";
+   41, "Ambiguous constructor or label name.";
+   42, "Disambiguated constructor or label name.";
+   43, "Nonoptional label applied as optional.";
+   44, "Open statement shadows an already defined identifier.";
+   45, "Open statement shadows an already defined label or constructor.";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 6720e49d..fa480653 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -10,14 +10,12 @@
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: warnings.mli 12504 2012-05-29 12:35:17Z frisch $ *)
-
 open Format
 
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated                              (*  3 *)
+  | Deprecated of string                    (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted                          (*  6 *)
@@ -44,16 +42,23 @@ type t =
   | Unused_var_strict of string             (* 27 *)
   | Wildcard_arg_to_constant_constr         (* 28 *)
   | Eol_in_string                           (* 29 *)
-  | Duplicate_definitions of string * string * string * string (*30 *)
+  | Duplicate_definitions of string * string * string * string (* 30 *)
   | Multiple_definition of string * string * string (* 31 *)
   | Unused_value_declaration of string      (* 32 *)
   | Unused_open of string                   (* 33 *)
   | Unused_type_declaration of string       (* 34 *)
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
-  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_constructor of string * bool * bool (* 37 *)
   | Unused_exception of string * bool       (* 38 *)
   | Unused_rec_flag                         (* 39 *)
+  | Name_out_of_scope of string * string list * bool   (* 40 *)
+  | Ambiguous_name of string list * string list * bool (* 41 *)
+  | Disambiguated_name of string            (* 42 *)
+  | Nonoptional_label of string             (* 43 *)
+  | Open_shadow_identifier of string * string (* 44 *)
+  | Open_shadow_label_constructor of string * string (* 45 *)
+  | Bad_env_variable of string * string
 ;;
 
 val parse_options : bool -> string -> unit;;
diff --git a/yacc/Makefile b/yacc/Makefile
index fc7abc7c..f5b37e00 100644
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -10,8 +10,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the parser generator.
 
 include ../config/Makefile
@@ -25,7 +23,7 @@ OBJS= closure.o error.o lalr.o lr0.o main.o mkpar.o output.o reader.o \
 all: ocamlyacc$(EXE)
 
 ocamlyacc$(EXE): $(OBJS)
-	$(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS)
+	$(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc$(EXE) $(OBJS)
 
 version.h : ../VERSION
 	echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
index d6759764..32caa41e 100644
--- a/yacc/Makefile.nt
+++ b/yacc/Makefile.nt
@@ -10,8 +10,6 @@
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 11156 2011-07-27 14:17:02Z doligez $
-
 # Makefile for the parser generator.
 
 include ../config/Makefile
diff --git a/yacc/closure.c b/yacc/closure.c
index 3eb8d2c9..d84c125b 100644
--- a/yacc/closure.c
+++ b/yacc/closure.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: closure.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "defs.h"
 
 short *itemset;
diff --git a/yacc/defs.h b/yacc/defs.h
index 990d36ae..0a823874 100644
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: defs.h 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include 
 #include 
diff --git a/yacc/error.c b/yacc/error.c
index c67552e6..bae0565a 100644
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: error.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 /* routines for printing error messages  */
 
 #include "defs.h"
diff --git a/yacc/lalr.c b/yacc/lalr.c
index f4f554dd..78199801 100644
--- a/yacc/lalr.c
+++ b/yacc/lalr.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: lalr.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "defs.h"
 
 typedef
diff --git a/yacc/lr0.c b/yacc/lr0.c
index 3a1e4259..a5a62d34 100644
--- a/yacc/lr0.c
+++ b/yacc/lr0.c
@@ -12,9 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: lr0.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
 #include "defs.h"
 
 extern short *itemset;
diff --git a/yacc/main.c b/yacc/main.c
index 035b3b3a..f6cac60d 100644
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: main.c 12800 2012-07-30 18:59:07Z doligez $ */
-
 #include 
 #include 
 #include "defs.h"
diff --git a/yacc/mkpar.c b/yacc/mkpar.c
index 33a874a3..55f4d4e5 100644
--- a/yacc/mkpar.c
+++ b/yacc/mkpar.c
@@ -12,9 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: mkpar.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
 #include "defs.h"
 
 action **parser;
diff --git a/yacc/output.c b/yacc/output.c
index b1247483..4a497ebb 100644
--- a/yacc/output.c
+++ b/yacc/output.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: output.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "defs.h"
 
 static int nvectors;
diff --git a/yacc/reader.c b/yacc/reader.c
index f4a26ea4..cf6d7021 100644
--- a/yacc/reader.c
+++ b/yacc/reader.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: reader.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "defs.h"
 
diff --git a/yacc/skeleton.c b/yacc/skeleton.c
index 6a957bb0..976bec63 100644
--- a/yacc/skeleton.c
+++ b/yacc/skeleton.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: skeleton.c 12834 2012-08-06 14:16:24Z doligez $ */
-
 #include "defs.h"
 
 char *header[] =
diff --git a/yacc/symtab.c b/yacc/symtab.c
index 1301dc29..9d6e2c33 100644
--- a/yacc/symtab.c
+++ b/yacc/symtab.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: symtab.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include 
 #include "defs.h"
 
diff --git a/yacc/verbose.c b/yacc/verbose.c
index 376cccaf..b28c8711 100644
--- a/yacc/verbose.c
+++ b/yacc/verbose.c
@@ -12,9 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: verbose.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-
 #include "defs.h"
 
 
diff --git a/yacc/warshall.c b/yacc/warshall.c
index 7207dc11..f341cdfb 100644
--- a/yacc/warshall.c
+++ b/yacc/warshall.c
@@ -12,8 +12,6 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
-/* $Id: warshall.c 11156 2011-07-27 14:17:02Z doligez $ */
-
 #include "defs.h"
 
 void transitive_closure(unsigned int *R, int n)